{-# 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 = [Package] -> Property DebianLike
Apt.installed [Package
"docker.io"] Property DebianLike
-> Property ArchLinux
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
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` [Package] -> Property ArchLinux
Pacman.installed [Package
"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
  (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
Property (HasInfo + DebianLike)
prop Property
  (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> CombinedType
     (Property
        (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
     (Property
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
Property (DebianLike + ArchLinux)
installed
  where
	prop :: Property (HasInfo + DebianLike)
	prop :: Property (HasInfo + DebianLike)
prop = PrivDataSource
-> Context
-> (((PrivData -> Propellor Result) -> Propellor Result)
    -> Property
         (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
-> Property
     (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
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 ((((PrivData -> Propellor Result) -> Propellor Result)
  -> Property
       (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
 -> Property
      (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
-> (((PrivData -> Propellor Result) -> Propellor Result)
    -> Property
         (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
-> Property
     (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall a b. (a -> b) -> a -> b
$ \(PrivData -> Propellor Result) -> Propellor Result
getcfg ->
		Package
-> (OuterMetaTypesWitness
      '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
    -> Propellor Result)
-> Property
     (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall k (metatypes :: k).
SingI metatypes =>
Package
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' Package
"docker configured" ((OuterMetaTypesWitness
    '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
  -> Propellor Result)
 -> Property
      (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
-> (OuterMetaTypesWitness
      '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
    -> Propellor Result)
-> Property
     (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w -> (PrivData -> Propellor Result) -> Propellor Result
getcfg ((PrivData -> Propellor Result) -> Propellor Result)
-> (PrivData -> Propellor Result) -> Propellor Result
forall a b. (a -> b) -> a -> b
$ \PrivData
cfg -> OuterMetaTypesWitness
  '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Propellor Result
forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w (Property
   (MetaTypes
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
 -> Propellor Result)
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Propellor Result
forall a b. (a -> b) -> a -> b
$
			Package
"/root/.dockercfg" Package
-> [Package]
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
`File.hasContent` PrivData -> [Package]
privDataLines PrivData
cfg
	src :: PrivDataSource
src = PrivDataField -> Package -> Package -> PrivDataSource
PrivDataSourceFileFromCommand PrivDataField
DockerAuthentication
		Package
"/root/.dockercfg" Package
"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) = Host -> [ChildProperty]
forall c. IsContainer c => c -> [ChildProperty]
containerProperties Host
h
	containerInfo :: Container -> Info
containerInfo (Container Image
_ Host
h) = Host -> Info
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 (Host -> [ChildProperty] -> Host
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 = Image -> Image
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 :: Package -> Image -> Props metatypes -> Container
container Package
cn Image
image (Props [ChildProperty]
ps) = Image -> Host -> Container
Container Image
image (Package -> [ChildProperty] -> Info -> Host
Host Package
cn [ChildProperty]
ps Info
info)
  where
	info :: Info
info = DockerInfo -> Info
dockerInfo DockerInfo
forall a. Monoid a => a
mempty Info -> Info -> Info
forall a. Semigroup a => a -> a -> a
<> [Info] -> Info
forall a. Monoid a => [a] -> a
mconcat ((ChildProperty -> Info) -> [ChildProperty] -> [Info]
forall a b. (a -> b) -> [a] -> [b]
map ChildProperty -> Info
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
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
docked ctr :: Container
ctr@(Container Image
_ Host
h) =
	(Container
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
propagateContainerInfo Container
ctr (Package
-> (ContainerId
    -> ContainerInfo
    -> Property
         (MetaTypes
            '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
               'Targeting 'OSArchLinux]))
-> Property
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
go Package
"docked" ContainerId
-> ContainerInfo
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
setup))
		Property
  (Sing
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Property
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> RevertableProperty
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!>
	(Package
-> (ContainerId
    -> ContainerInfo
    -> Property
         (MetaTypes
            '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
               'Targeting 'OSArchLinux]))
-> Property
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
go Package
"undocked" ContainerId
-> ContainerInfo
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
teardown)
  where
	cn :: Package
cn = Host -> Package
hostName Host
h

	go :: Package
-> (ContainerId
    -> ContainerInfo
    -> Property
         (MetaTypes
            '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
               'Targeting 'OSArchLinux]))
-> Property
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
go Package
desc ContainerId
-> ContainerInfo
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
a = Package
-> (OuterMetaTypesWitness
      '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    -> Propellor Result)
-> Property
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall k (metatypes :: k).
SingI metatypes =>
Package
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' (Package
desc Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ Package
" " Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ Package
cn) ((OuterMetaTypesWitness
    '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
       'Targeting 'OSArchLinux]
  -> Propellor Result)
 -> Property
      (Sing
         '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> (OuterMetaTypesWitness
      '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    -> Propellor Result)
-> Property
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
     'Targeting 'OSArchLinux]
w -> do
		Package
hn <- (Host -> Package) -> Propellor Package
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Host -> Package
hostName
		let cid :: ContainerId
cid = Package -> Package -> ContainerId
ContainerId Package
hn Package
cn
		OuterMetaTypesWitness
  '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
     'Targeting 'OSArchLinux]
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Propellor Result
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 (Property
   (MetaTypes
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux])
 -> Propellor Result)
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Propellor Result
forall a b. (a -> b) -> a -> b
$ ContainerId
-> ContainerInfo
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
a ContainerId
cid (ContainerId -> Container -> ContainerInfo
mkContainerInfo ContainerId
cid Container
ctr)

	setup :: ContainerId -> ContainerInfo -> Property Linux
	setup :: ContainerId
-> ContainerInfo
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
setup ContainerId
cid (ContainerInfo Image
image [Package]
runparams) =
		ContainerId
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
provisionContainer ContainerId
cid
			Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> CombinedType
     (Property
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
     (Property
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
forall x y. Combines x y => x -> y -> CombinedType x y
`requires`
		ContainerId
-> Image
-> [Package]
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
runningContainer ContainerId
cid Image
image [Package]
runparams
			Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> CombinedType
     (Property
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
     (Property
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
forall x y. Combines x y => x -> y -> CombinedType x y
`requires`
		Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
Property (DebianLike + ArchLinux)
installed

	teardown :: ContainerId -> ContainerInfo -> Property Linux
	teardown :: ContainerId
-> ContainerInfo
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
teardown ContainerId
cid (ContainerInfo Image
image [Package]
_runparams) =
		Package
-> Props
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall k (metatypes :: k).
SingI metatypes =>
Package
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
combineProperties (Package
"undocked " Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ ContainerId -> Package
fromContainerId ContainerId
cid) (Props
   (MetaTypes
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux])
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Props
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ [Property
   (MetaTypes
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux])]
-> Props
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall k (metatypes :: k).
[Property (MetaTypes metatypes)] -> Props (MetaTypes metatypes)
toProps
			[ ContainerId
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
stoppedContainer ContainerId
cid
			, Package
-> Propellor Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall k (metatypes :: k).
SingI metatypes =>
Package -> Propellor Result -> Property (MetaTypes metatypes)
property (Package
"cleaned up " Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ ContainerId -> Package
fromContainerId ContainerId
cid) (Propellor Result
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Propellor Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$
				IO Result -> Propellor Result
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> Propellor Result) -> IO Result -> Propellor Result
forall a b. (a -> b) -> a -> b
$ [Bool] -> Result
report ([Bool] -> Result) -> IO [Bool] -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO Bool -> IO Bool) -> [IO Bool] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM IO Bool -> IO Bool
forall a. a -> a
id
					[ ContainerId -> IO Bool
removeContainer ContainerId
cid
					, Image -> IO Bool
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 :: Package
-> c
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
imageBuilt Package
directory c
ctr = Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
built Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Package
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall p. IsProp p => p -> Package -> p
`describe` Package
msg
  where
	msg :: Package
msg = Package
"docker image " Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ (Image -> Package
forall i. ImageIdentifier i => i -> Package
imageIdentifier Image
image) Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ Package
" built from " Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ Package
directory
	built :: Property Linux
	built :: Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
built = Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property
   (MetaTypes
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$
		Package
-> [Package]
-> (CreateProcess -> CreateProcess)
-> UncheckedProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
Cmd.cmdProperty' Package
dockercmd [Package
"build", Package
"--tag", Image -> Package
forall i. ImageIdentifier i => i -> Package
imageIdentifier Image
image, Package
"./"] CreateProcess -> CreateProcess
workDir
			UncheckedProperty
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
	workDir :: CreateProcess -> CreateProcess
workDir CreateProcess
p = CreateProcess
p { cwd :: Maybe Package
cwd = Package -> Maybe Package
forall a. a -> Maybe a
Just Package
directory }
	image :: Image
image = c -> 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 :: c
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
imagePulled c
ctr = Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
pulled Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Package
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall p. IsProp p => p -> Package -> p
`describe` Package
msg
  where
	msg :: Package
msg = Package
"docker image " Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ (Image -> Package
forall i. ImageIdentifier i => i -> Package
imageIdentifier Image
image) Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ Package
" pulled"
	pulled :: Property Linux
	pulled :: Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
pulled = Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property
   (MetaTypes
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ 
		Package
-> [Package]
-> UncheckedProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
Cmd.cmdProperty Package
dockercmd [Package
"pull", Image -> Package
forall i. ImageIdentifier i => i -> Package
imageIdentifier Image
image]
			UncheckedProperty
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
	image :: Image
image = c -> Image
forall a. HasImage a => a -> Image
getImageName c
ctr

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

mkContainerInfo :: ContainerId -> Container -> ContainerInfo
mkContainerInfo :: ContainerId -> Container -> ContainerInfo
mkContainerInfo cid :: ContainerId
cid@(ContainerId Package
hn Package
_cn) (Container Image
img Host
h) =
	Image -> [Package] -> ContainerInfo
ContainerInfo Image
img [Package]
runparams
  where
	runparams :: [Package]
runparams = (DockerRunParam -> Package) -> [DockerRunParam] -> [Package]
forall a b. (a -> b) -> [a] -> [b]
map (\(DockerRunParam Package -> Package
mkparam) -> Package -> Package
mkparam Package
hn)
		(DockerInfo -> [DockerRunParam]
_dockerRunParams DockerInfo
info)
	info :: DockerInfo
info = Info -> DockerInfo
forall v. IsInfo v => Info -> v
fromInfo (Info -> DockerInfo) -> Info -> DockerInfo
forall a b. (a -> b) -> a -> b
$ Host -> Info
hostInfo Host
h'
	h' :: Host
h' = Host
-> Props
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Host
forall c metatypes. IsContainer c => c -> Props metatypes -> c
setContainerProps Host
h (Props
   (Sing
      '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux])
 -> Host)
-> Props
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Host
forall a b. (a -> b) -> a -> b
$ Host
-> Props
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
forall c.
IsContainer c =>
c
-> Props
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
containerProps Host
h
		-- Restart by default so container comes up on
		-- boot or when docker is upgraded.
		Props
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Props
     (MetaTypes
        (Combine
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
           '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
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
  (Sing
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
Property
  (HasInfo
   + MetaTypes
       '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
          'Targeting 'OSArchLinux])
restartAlways
		-- Expose propellor directory inside the container.
		Props
  (Sing
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Property
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Props
     (MetaTypes
        (Combine
           '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]
           '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
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))
& Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
forall v.
Mountable v =>
v
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
volume (Package
localdirPackage -> Package -> Package
forall a. [a] -> [a] -> [a]
++Package
":"Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++Package
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.
		Props
  (Sing
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Property
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Props
     (MetaTypes
        (Combine
           '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]
           '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
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))
& Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
name (ContainerId -> Package
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
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
garbageCollected = Package
-> Props
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall k (metatypes :: k).
SingI metatypes =>
Package
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
propertyList Package
"docker garbage collected" (Props
   (MetaTypes
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux])
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Props
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ Props
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
props
	Props
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Props
     (MetaTypes
        (Combine
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
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
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
gccontainers
	Props
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Props
     (MetaTypes
        (Combine
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
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
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
gcimages
  where
	gccontainers :: Property Linux
	gccontainers :: Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
gccontainers = Package
-> Propellor Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall k (metatypes :: k).
SingI metatypes =>
Package -> Propellor Result -> Property (MetaTypes metatypes)
property Package
"docker containers garbage collected" (Propellor Result
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Propellor Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$
		IO Result -> Propellor Result
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> Propellor Result) -> IO Result -> Propellor Result
forall a b. (a -> b) -> a -> b
$ [Bool] -> Result
report ([Bool] -> Result) -> IO [Bool] -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ContainerId -> IO Bool) -> [ContainerId] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ContainerId -> IO Bool
removeContainer ([ContainerId] -> IO [Bool]) -> IO [ContainerId] -> IO [Bool]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ContainerFilter -> IO [ContainerId]
listContainers ContainerFilter
AllContainers)
	gcimages :: Property Linux
	gcimages :: Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
gcimages = Package
-> Propellor Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall k (metatypes :: k).
SingI metatypes =>
Package -> Propellor Result -> Property (MetaTypes metatypes)
property Package
"docker images garbage collected" (Propellor Result
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Propellor Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$
		IO Result -> Propellor Result
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> Propellor Result) -> IO Result -> Propellor Result
forall a b. (a -> b) -> a -> b
$ [Bool] -> Result
report ([Bool] -> Result) -> IO [Bool] -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ImageUID -> IO Bool) -> [ImageUID] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ImageUID -> IO Bool
forall i. ImageIdentifier i => i -> IO Bool
removeImage ([ImageUID] -> IO [Bool]) -> IO [ImageUID] -> IO [Bool]
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
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
tweaked = Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property
   (MetaTypes
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ Package
-> [Package]
-> UncheckedProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
cmdProperty Package
"sh"
	[ Package
"-c"
	, Package
"sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"
	]
	UncheckedProperty
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
NoChange
	Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Package
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
forall p. IsProp p => p -> Package -> p
`describe` Package
"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 = Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property DebianLike
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property
   (MetaTypes
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
 -> Property DebianLike)
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property DebianLike
forall a b. (a -> b) -> a -> b
$
	Package
"/etc/default/grub" Package
-> Package
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
`File.containsLine` Package
cfg
		Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Package
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
forall p. IsProp p => p -> Package -> p
`describe` Package
"docker memory limited"
		Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> CombinedType
     (Property
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
     (Property
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` (Package
-> [Package]
-> UncheckedProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
cmdProperty Package
"update-grub" [] UncheckedProperty
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange)
  where
	cmdline :: Package
cmdline = Package
"cgroup_enable=memory swapaccount=1"
	cfg :: Package
cfg = Package
"GRUB_CMDLINE_LINUX_DEFAULT=\""Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++Package
cmdlinePackage -> Package -> Package
forall a. [a] -> [a] -> [a]
++Package
"\""

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 = Package -> ImageID
ImageID (Package -> ImageID) -> (i -> Package) -> i -> ImageID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Package
forall i. ImageIdentifier i => i -> Package
imageIdentifier
	-- | A string that Docker can use as an image identifier.
	imageIdentifier :: i -> String

instance ImageIdentifier ImageID where
	imageIdentifier :: ImageID -> Package
imageIdentifier (ImageID Package
i) = Package
i
	toImageID :: ImageID -> ImageID
toImageID = ImageID -> ImageID
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 -> Package
repository :: String
	, Image -> Maybe Package
tag :: Maybe String
	}
	deriving (Image -> Image -> Bool
(Image -> Image -> Bool) -> (Image -> Image -> Bool) -> Eq Image
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]
(Int -> ReadS Image)
-> ReadS [Image]
-> ReadPrec Image
-> ReadPrec [Image]
-> Read 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 -> Package -> Package
[Image] -> Package -> Package
Image -> Package
(Int -> Image -> Package -> Package)
-> (Image -> Package)
-> ([Image] -> Package -> Package)
-> Show Image
forall a.
(Int -> a -> Package -> Package)
-> (a -> Package) -> ([a] -> Package -> Package) -> Show a
showList :: [Image] -> Package -> Package
$cshowList :: [Image] -> Package -> Package
show :: Image -> Package
$cshow :: Image -> Package
showsPrec :: Int -> Image -> Package -> Package
$cshowsPrec :: Int -> Image -> Package -> Package
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 :: Package -> Image
latestImage Package
repo = Package -> Maybe Package -> Image
Image Package
repo Maybe Package
forall a. Maybe a
Nothing

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

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

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

-- | Set custom dns server for container.
dns :: String -> Property (HasInfo + Linux)
dns :: Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
dns = Package
-> Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
runProp Package
"dns"

-- | Set container host name.
hostname :: String -> Property (HasInfo + Linux)
hostname :: Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
hostname = Package
-> Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
runProp Package
"hostname"

-- | Set name of container.
name :: String -> Property (HasInfo + Linux)
name :: Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
name = Package
-> Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
runProp Package
"name"

class Publishable p where
	toPublish :: p -> String

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

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

-- | Publish a container's port to the host
publish :: Publishable p => p -> Property (HasInfo + Linux)
publish :: p
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
publish = Package
-> Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
runProp Package
"publish" (Package
 -> Property
      (Sing
         '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> (p -> Package)
-> p
-> Property
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> Package
forall p. Publishable p => p -> Package
toPublish

-- | Expose a container's port without publishing it.
expose :: String -> Property (HasInfo + Linux)
expose :: Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
expose = Package
-> Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
runProp Package
"expose"

-- | Username or UID for container.
user :: String -> Property (HasInfo + Linux)
user :: Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
user = Package
-> Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
runProp Package
"user"

class Mountable p where
	toMount :: p -> String

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

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

-- | Mount a volume
volume :: Mountable v => v -> Property (HasInfo + Linux)
volume :: v
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
volume = Package
-> Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
runProp Package
"volume" (Package
 -> Property
      (Sing
         '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> (v -> Package)
-> v
-> Property
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Package
forall p. Mountable p => p -> Package
toMount

-- | Mount a volume from the specified container into the current
-- container.
volumes_from :: ContainerName -> Property (HasInfo + Linux)
volumes_from :: Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
volumes_from Package
cn = Package
-> (Package -> Package)
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
genProp Package
"volumes-from" ((Package -> Package)
 -> Property
      (HasInfo
       + MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
-> (Package -> Package)
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ \Package
hn ->
	ContainerId -> Package
fromContainerId (Package -> Package -> ContainerId
ContainerId Package
hn Package
cn)

-- | Work dir inside the container.
workdir :: String -> Property (HasInfo + Linux)
workdir :: Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
workdir = Package
-> Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
runProp Package
"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 :: Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
memory = Package
-> Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
runProp Package
"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
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
cpuShares = Package
-> Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
runProp Package
"cpu-shares" (Package
 -> Property
      (Sing
         '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> (Int -> Package)
-> Int
-> Property
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Package
forall a. Show a => a -> Package
show

-- | Link with another container on the same host.
link :: ContainerName -> ContainerAlias -> Property (HasInfo + Linux)
link :: Package
-> Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
link Package
linkwith Package
calias = Package
-> (Package -> Package)
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
genProp Package
"link" ((Package -> Package)
 -> Property
      (HasInfo
       + MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
-> (Package -> Package)
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ \Package
hn ->
	ContainerId -> Package
fromContainerId (Package -> Package -> ContainerId
ContainerId Package
hn Package
linkwith) Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ Package
":" Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ Package
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
   + MetaTypes
       '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
          'Targeting 'OSArchLinux])
restartAlways = Package
-> Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
runProp Package
"restart" Package
"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
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
restartOnFailure Maybe Int
Nothing = Package
-> Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
runProp Package
"restart" Package
"on-failure"
restartOnFailure (Just Int
n) = Package
-> Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
runProp Package
"restart" (Package
"on-failure:" Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ Int -> Package
forall a. Show a => a -> Package
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
   + MetaTypes
       '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
          'Targeting 'OSArchLinux])
restartNever = Package
-> Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
runProp Package
"restart" Package
"no"

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

-- | A container is identified by its name, and the host
-- on which it's deployed.
data ContainerId = ContainerId
	{ ContainerId -> Package
containerHostName :: HostName
	, ContainerId -> Package
containerName :: ContainerName
	}
	deriving (ContainerId -> ContainerId -> Bool
(ContainerId -> ContainerId -> Bool)
-> (ContainerId -> ContainerId -> Bool) -> Eq ContainerId
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]
(Int -> ReadS ContainerId)
-> ReadS [ContainerId]
-> ReadPrec ContainerId
-> ReadPrec [ContainerId]
-> Read 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 -> Package -> Package
[ContainerId] -> Package -> Package
ContainerId -> Package
(Int -> ContainerId -> Package -> Package)
-> (ContainerId -> Package)
-> ([ContainerId] -> Package -> Package)
-> Show ContainerId
forall a.
(Int -> a -> Package -> Package)
-> (a -> Package) -> ([a] -> Package -> Package) -> Show a
showList :: [ContainerId] -> Package -> Package
$cshowList :: [ContainerId] -> Package -> Package
show :: ContainerId -> Package
$cshow :: ContainerId -> Package
showsPrec :: Int -> ContainerId -> Package -> Package
$cshowsPrec :: Int -> ContainerId -> Package -> Package
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]
(Int -> ReadS ContainerIdent)
-> ReadS [ContainerIdent]
-> ReadPrec ContainerIdent
-> ReadPrec [ContainerIdent]
-> Read 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 -> Package -> Package
[ContainerIdent] -> Package -> Package
ContainerIdent -> Package
(Int -> ContainerIdent -> Package -> Package)
-> (ContainerIdent -> Package)
-> ([ContainerIdent] -> Package -> Package)
-> Show ContainerIdent
forall a.
(Int -> a -> Package -> Package)
-> (a -> Package) -> ([a] -> Package -> Package) -> Show a
showList :: [ContainerIdent] -> Package -> Package
$cshowList :: [ContainerIdent] -> Package -> Package
show :: ContainerIdent -> Package
$cshow :: ContainerIdent -> Package
showsPrec :: Int -> ContainerIdent -> Package -> Package
$cshowsPrec :: Int -> ContainerIdent -> Package -> Package
Show, ContainerIdent -> ContainerIdent -> Bool
(ContainerIdent -> ContainerIdent -> Bool)
-> (ContainerIdent -> ContainerIdent -> Bool) -> Eq ContainerIdent
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 :: Package -> Maybe ContainerId
toContainerId Package
s
	| Package
myContainerSuffix Package -> Package -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Package
s = case (Char -> Bool) -> Package -> (Package, Package)
forall a. (a -> Bool) -> [a] -> ([a], [a])
separate (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') (Package -> Package
forall a. [a] -> [a]
desuffix Package
s) of
		(Package
cn, Package
hn)
			| Package -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Package
hn Bool -> Bool -> Bool
|| Package -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Package
cn -> Maybe ContainerId
forall a. Maybe a
Nothing
			| Bool
otherwise -> ContainerId -> Maybe ContainerId
forall a. a -> Maybe a
Just (ContainerId -> Maybe ContainerId)
-> ContainerId -> Maybe ContainerId
forall a b. (a -> b) -> a -> b
$ Package -> Package -> ContainerId
ContainerId Package
hn Package
cn
	| Bool
otherwise = Maybe ContainerId
forall a. Maybe a
Nothing
  where
	desuffix :: [a] -> [a]
desuffix = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
len ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. [a] -> [a]
reverse
	len :: Int
len = Package -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Package
myContainerSuffix

fromContainerId :: ContainerId -> String
fromContainerId :: ContainerId -> Package
fromContainerId (ContainerId Package
hn Package
cn) = Package
cnPackage -> Package -> Package
forall a. [a] -> [a] -> [a]
++Package
"."Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++Package
hnPackage -> Package -> Package
forall a. [a] -> [a] -> [a]
++Package
myContainerSuffix

myContainerSuffix :: String
myContainerSuffix :: Package
myContainerSuffix = Package
".propellor"

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

runningContainer :: ContainerId -> Image -> [RunParam] -> Property Linux
runningContainer :: ContainerId
-> Image
-> [Package]
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
runningContainer cid :: ContainerId
cid@(ContainerId Package
hn Package
cn) Image
image [Package]
runps = ContainerId
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall i.
IsProp (Property i) =>
ContainerId -> Property i -> Property i
containerDesc ContainerId
cid (Property
   (MetaTypes
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux])
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ Package
-> Propellor Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall k (metatypes :: k).
SingI metatypes =>
Package -> Propellor Result -> Property (MetaTypes metatypes)
property Package
"running" (Propellor Result
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Propellor Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ do
	[ContainerId]
l <- IO [ContainerId] -> Propellor [ContainerId]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ContainerId] -> Propellor [ContainerId])
-> IO [ContainerId] -> Propellor [ContainerId]
forall a b. (a -> b) -> a -> b
$ ContainerFilter -> IO [ContainerId]
listContainers ContainerFilter
RunningContainers
	if ContainerId
cid ContainerId -> [ContainerId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ContainerId]
l
		then Either Package (Maybe ContainerIdent) -> Propellor Result
checkident (Either Package (Maybe ContainerIdent) -> Propellor Result)
-> Propellor (Either Package (Maybe ContainerIdent))
-> Propellor Result
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either Package (Maybe ContainerIdent))
-> Propellor (Either Package (Maybe ContainerIdent))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Either Package (Maybe ContainerIdent))
getrunningident
		else Propellor Bool
-> (Propellor Result, Propellor Result) -> Propellor Result
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (IO Bool -> Propellor Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Propellor Bool) -> IO Bool -> Propellor Bool
forall a b. (a -> b) -> a -> b
$ ContainerId -> [ContainerId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ContainerId
cid ([ContainerId] -> Bool) -> IO [ContainerId] -> IO Bool
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.
				Propellor Bool -> Propellor ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Propellor Bool -> Propellor ()) -> Propellor Bool -> Propellor ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> Propellor Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Propellor Bool) -> IO Bool -> Propellor Bool
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 Package (Maybe ContainerIdent) -> Propellor Result
checkident (Either Package (Maybe ContainerIdent) -> Propellor Result)
-> Propellor (Either Package (Maybe ContainerIdent))
-> Propellor Result
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either Package (Maybe ContainerIdent))
-> Propellor (Either Package (Maybe ContainerIdent))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int
-> IO (Either Package (Maybe ContainerIdent))
-> IO (Either Package (Maybe ContainerIdent))
forall e a.
Int -> IO (Either e (Maybe a)) -> IO (Either e (Maybe a))
retry Int
60 (IO (Either Package (Maybe ContainerIdent))
 -> IO (Either Package (Maybe ContainerIdent)))
-> IO (Either Package (Maybe ContainerIdent))
-> IO (Either Package (Maybe ContainerIdent))
forall a b. (a -> b) -> a -> b
$ IO (Either Package (Maybe ContainerIdent))
getrunningident)
			, Image -> Propellor Result
forall i. ImageIdentifier i => i -> Propellor Result
go Image
image
			)
  where
	ident :: ContainerIdent
ident = Image -> Package -> Package -> [Package] -> ContainerIdent
ContainerIdent Image
image Package
hn Package
cn [Package]
runps

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

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

	getrunningident :: IO (Either Package (Maybe ContainerIdent))
getrunningident = Package
-> (Package
    -> Handle -> IO (Either Package (Maybe ContainerIdent)))
-> IO (Either Package (Maybe ContainerIdent))
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Package -> (Package -> Handle -> m a) -> m a
withTmpFile Package
"dockerrunsane" ((Package -> Handle -> IO (Either Package (Maybe ContainerIdent)))
 -> IO (Either Package (Maybe ContainerIdent)))
-> (Package
    -> Handle -> IO (Either Package (Maybe ContainerIdent)))
-> IO (Either Package (Maybe ContainerIdent))
forall a b. (a -> b) -> a -> b
$ \Package
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
		IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ())
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO Bool)
-> (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessHandle -> IO Bool
checkSuccessProcess (ProcessHandle -> IO Bool)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> ProcessHandle)
-> (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ProcessHandle
processHandle ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> IO ())
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
			CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (ContainerId -> [Package] -> [Package] -> CreateProcess
inContainerProcess ContainerId
cid []
				[Package
"rm", Package
"-f", Package
t])
		IO Bool
-> (IO (Either Package (Maybe ContainerIdent)),
    IO (Either Package (Maybe ContainerIdent)))
-> IO (Either Package (Maybe ContainerIdent))
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (Package -> IO Bool
doesFileExist Package
t)
			( Maybe ContainerIdent -> Either Package (Maybe ContainerIdent)
forall a b. b -> Either a b
Right (Maybe ContainerIdent -> Either Package (Maybe ContainerIdent))
-> (Package -> Maybe ContainerIdent)
-> Package
-> Either Package (Maybe ContainerIdent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Package -> Maybe ContainerIdent
forall a. Read a => Package -> Maybe a
readish (Package -> Either Package (Maybe ContainerIdent))
-> IO Package -> IO (Either Package (Maybe ContainerIdent))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
				CreateProcess -> IO Package
readProcess' (ContainerId -> [Package] -> [Package] -> CreateProcess
inContainerProcess ContainerId
cid []
					[Package
"cat", Package
propellorIdent])
			, Either Package (Maybe ContainerIdent)
-> IO (Either Package (Maybe ContainerIdent))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Package (Maybe ContainerIdent)
 -> IO (Either Package (Maybe ContainerIdent)))
-> Either Package (Maybe ContainerIdent)
-> IO (Either Package (Maybe ContainerIdent))
forall a b. (a -> b) -> a -> b
$ Package -> Either Package (Maybe ContainerIdent)
forall a b. a -> Either a b
Left Package
"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 :: Int -> IO (Either e (Maybe a)) -> IO (Either e (Maybe a))
retry Int
0 IO (Either e (Maybe a))
_ = Either e (Maybe a) -> IO (Either e (Maybe a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> Either e (Maybe a)
forall a b. b -> Either a b
Right Maybe a
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)
				Int -> IO (Either e (Maybe a)) -> IO (Either e (Maybe a))
forall e a.
Int -> IO (Either e (Maybe a)) -> IO (Either e (Maybe a))
retry (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) IO (Either e (Maybe a))
a
			Either e (Maybe a)
_ -> Either e (Maybe a) -> IO (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 :: i -> Propellor Result
go i
img = IO Result -> Propellor Result
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> Propellor Result) -> IO Result -> Propellor Result
forall a b. (a -> b) -> a -> b
$ do
		ContainerId -> IO ()
clearProvisionedFlag ContainerId
cid
		Bool -> Package -> IO ()
createDirectoryIfMissing Bool
True (Package -> Package
takeDirectory (Package -> Package) -> Package -> Package
forall a b. (a -> b) -> a -> b
$ ContainerId -> Package
identFile ContainerId
cid)
		Package
shim <- Package -> Maybe Package -> Package -> IO Package
Shim.setup (Package
localdir Package -> Package -> Package
</> Package
"propellor") Maybe Package
forall a. Maybe a
Nothing (Package
localdir Package -> Package -> Package
</> ContainerId -> Package
shimdir ContainerId
cid)
		Package -> Package -> IO ()
writeFile (ContainerId -> Package
identFile ContainerId
cid) (ContainerIdent -> Package
forall a. Show a => a -> Package
show ContainerIdent
ident)
		Bool -> Result
forall t. ToResult t => t -> Result
toResult (Bool -> Result) -> IO Bool -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> i -> [Package] -> [Package] -> IO Bool
forall i.
ImageIdentifier i =>
i -> [Package] -> [Package] -> IO Bool
runContainer i
img
			([Package]
runps [Package] -> [Package] -> [Package]
forall a. [a] -> [a] -> [a]
++ [Package
"-i", Package
"-d", Package
"-t"])
			[Package
shim, Package
"--continue", CmdLine -> Package
forall a. Show a => a -> Package
show (Package -> CmdLine
DockerInit (ContainerId -> Package
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 :: Package -> IO ()
init Package
s = case Package -> Maybe ContainerId
toContainerId Package
s of
	Maybe ContainerId
Nothing -> Package -> IO ()
forall a. HasCallStack => Package -> a
error (Package -> IO ()) -> Package -> IO ()
forall a b. (a -> b) -> a -> b
$ Package
"Invalid ContainerId: " Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ Package
s
	Just ContainerId
cid -> do
		Package -> IO ()
changeWorkingDirectory Package
localdir
		Package -> Package -> IO ()
writeFile Package
propellorIdent (Package -> IO ())
-> (ContainerIdent -> Package) -> ContainerIdent -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContainerIdent -> Package
forall a. Show a => a -> Package
show (ContainerIdent -> IO ()) -> IO ContainerIdent -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ContainerId -> IO ContainerIdent
readIdentFile ContainerId
cid
		IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (ContainerId -> IO Bool
checkProvisionedFlag ContainerId
cid) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
			let shim :: Package
shim = Package -> Package -> Package
Shim.file (Package
localdir Package -> Package -> Package
</> Package
"propellor") (Package
localdir Package -> Package -> Package
</> ContainerId -> Package
shimdir ContainerId
cid)
			IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Package -> [CommandParam] -> IO Bool
boolSystem Package
shim [Package -> CommandParam
Param Package
"--continue", Package -> CommandParam
Param (Package -> CommandParam) -> Package -> CommandParam
forall a b. (a -> b) -> a -> b
$ CmdLine -> Package
forall a. Show a => a -> Package
show (CmdLine -> Package) -> CmdLine -> Package
forall a b. (a -> b) -> a -> b
$ ContainerId -> CmdLine
toChain ContainerId
cid]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
				Package -> IO ()
forall (m :: * -> *). MonadIO m => Package -> m ()
warningMessage Package
"Boot provision failed!"
		IO (Async Any) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async Any) -> IO ()) -> IO (Async Any) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Any -> IO (Async Any)
forall a. IO a -> IO (Async a)
async (IO Any -> IO (Async Any)) -> IO Any -> IO (Async Any)
forall a b. (a -> b) -> a -> b
$ IO () -> IO Any
forall a b. IO a -> IO b
job IO ()
reapzombies
		IO () -> IO ()
forall a b. IO a -> IO b
job (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
			IO ()
flushConcurrentOutput
			IO (Either IOException Bool) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException Bool) -> IO ())
-> IO (Either IOException Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO (Either IOException Bool)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO (IO Bool -> IO (Either IOException Bool))
-> IO Bool -> IO (Either IOException Bool)
forall a b. (a -> b) -> a -> b
$ IO Bool -> (IO Bool, IO Bool) -> IO Bool
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (Package -> IO Bool
inPath Package
"bash")
				( Package -> [CommandParam] -> IO Bool
boolSystem Package
"bash" [Package -> CommandParam
Param Package
"-l"]
				, Package -> [CommandParam] -> IO Bool
boolSystem Package
"/bin/sh" []
				)
			Package -> IO ()
putStrLn Package
"Container is still running. Press ^P^Q to detach."
  where
	job :: IO a -> IO b
job = IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> (IO a -> IO ()) -> IO a -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either IOException a) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException a) -> IO ())
-> (IO a -> IO (Either IOException a)) -> IO a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO (Either IOException a)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO
	reapzombies :: IO ()
reapzombies = IO (Maybe (ProcessID, ProcessStatus)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (ProcessID, ProcessStatus)) -> IO ())
-> IO (Maybe (ProcessID, ProcessStatus)) -> IO ()
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
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
provisionContainer ContainerId
cid = ContainerId
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall i.
IsProp (Property i) =>
ContainerId -> Property i -> Property i
containerDesc ContainerId
cid (Property
   (MetaTypes
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux])
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ Package
-> Propellor Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall k (metatypes :: k).
SingI metatypes =>
Package -> Propellor Result -> Property (MetaTypes metatypes)
property Package
"provisioned" (Propellor Result
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Propellor Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ IO Result -> Propellor Result
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> Propellor Result) -> IO Result -> Propellor Result
forall a b. (a -> b) -> a -> b
$ do
	let shim :: Package
shim = Package -> Package -> Package
Shim.file (Package
localdir Package -> Package -> Package
</> Package
"propellor") (Package
localdir Package -> Package -> Package
</> ContainerId -> Package
shimdir ContainerId
cid)
	let params :: [Package]
params = [Package
"--continue", CmdLine -> Package
forall a. Show a => a -> Package
show (CmdLine -> Package) -> CmdLine -> Package
forall a b. (a -> b) -> a -> b
$ ContainerId -> CmdLine
toChain ContainerId
cid]
	MessageHandle
msgh <- IO MessageHandle
getMessageHandle
	let p :: CreateProcess
p = ContainerId -> [Package] -> [Package] -> CreateProcess
inContainerProcess ContainerId
cid
		(if MessageHandle -> Bool
isConsole MessageHandle
msgh then [Package
"-it"] else [])
		(Package
shim Package -> [Package] -> [Package]
forall a. a -> [a] -> [a]
: [Package]
params)
	Result
r <- CreateProcess -> IO Result
chainPropellor CreateProcess
p
	Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Result
r Result -> Result -> Bool
forall a. Eq a => a -> a -> Bool
/= Result
FailedChange) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
		ContainerId -> IO ()
setProvisionedFlag ContainerId
cid
	Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r

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

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

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

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

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

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

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

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

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

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

data ContainerFilter = RunningContainers | AllContainers
	deriving (ContainerFilter -> ContainerFilter -> Bool
(ContainerFilter -> ContainerFilter -> Bool)
-> (ContainerFilter -> ContainerFilter -> Bool)
-> Eq ContainerFilter
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 =
	(Package -> Maybe ContainerId) -> [Package] -> [ContainerId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Package -> Maybe ContainerId
toContainerId ([Package] -> [ContainerId])
-> (Package -> [Package]) -> Package -> [ContainerId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Package -> [Package]) -> [Package] -> [Package]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Package -> Package -> [Package]
forall a. Eq a => [a] -> [a] -> [[a]]
split Package
",")
		([Package] -> [Package])
-> (Package -> [Package]) -> Package -> [Package]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Package -> Maybe Package) -> [Package] -> [Package]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Package] -> Maybe Package
forall a. [a] -> Maybe a
lastMaybe ([Package] -> Maybe Package)
-> (Package -> [Package]) -> Package -> Maybe Package
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Package -> [Package]
words) ([Package] -> [Package])
-> (Package -> [Package]) -> Package -> [Package]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Package -> [Package]
lines
		(Package -> [ContainerId]) -> IO Package -> IO [ContainerId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Package -> [Package] -> IO Package
readProcess Package
dockercmd [Package]
ps
  where
	ps :: [Package]
ps
		| ContainerFilter
status ContainerFilter -> ContainerFilter -> Bool
forall a. Eq a => a -> a -> Bool
== ContainerFilter
AllContainers = [Package]
baseps [Package] -> [Package] -> [Package]
forall a. [a] -> [a] -> [a]
++ [Package
"--all"]
		| Bool
otherwise = [Package]
baseps
	baseps :: [Package]
baseps = [Package
"ps", Package
"--no-trunc"]

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

runProp :: String -> RunParam -> Property (HasInfo + Linux)
runProp :: Package
-> Package
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
runProp Package
field Package
v = Property
  (MetaTypes
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property
   (MetaTypes
      '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
 -> Property
      (Sing
         '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Property
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ Package
-> DockerInfo
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
forall v.
IsInfo v =>
Package
-> v
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
pureInfoProperty (Package
param) (DockerInfo
 -> Property
      (HasInfo
       + MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
-> DockerInfo
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
forall a b. (a -> b) -> a -> b
$
	DockerInfo
forall a. Monoid a => a
mempty { _dockerRunParams :: [DockerRunParam]
_dockerRunParams = [(Package -> Package) -> DockerRunParam
DockerRunParam (\Package
_ -> Package
"--"Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++Package
param)] }
  where
	param :: Package
param = Package
fieldPackage -> Package -> Package
forall a. [a] -> [a] -> [a]
++Package
"="Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++Package
v

genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux)
genProp :: Package
-> (Package -> Package)
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
genProp Package
field Package -> Package
mkval = Property
  (MetaTypes
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property
   (MetaTypes
      '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
 -> Property
      (Sing
         '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Property
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
     (Sing
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ Package
-> DockerInfo
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
forall v.
IsInfo v =>
Package
-> v
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
pureInfoProperty Package
field (DockerInfo
 -> Property
      (HasInfo
       + MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
-> DockerInfo
-> Property
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
forall a b. (a -> b) -> a -> b
$
	DockerInfo
forall a. Monoid a => a
mempty { _dockerRunParams :: [DockerRunParam]
_dockerRunParams = [(Package -> Package) -> DockerRunParam
DockerRunParam (\Package
hn -> Package
"--"Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++Package
fieldPackage -> Package -> Package
forall a. [a] -> [a] -> [a]
++Package
"=" Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ Package -> Package
mkval Package
hn)] }

dockerInfo :: DockerInfo -> Info
dockerInfo :: DockerInfo -> Info
dockerInfo DockerInfo
i = Info
forall a. Monoid a => a
mempty Info -> DockerInfo -> Info
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 :: Package
propellorIdent = Package
"/.propellor-ident"

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

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

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

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

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

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

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

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

dockercmd :: String
dockercmd :: Package
dockercmd = Package
"docker"

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