{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}
module Propellor.Property.Docker (
installed,
configured,
container,
docked,
imageBuilt,
imagePulled,
memoryLimited,
garbageCollected,
tweaked,
Image(..),
latestImage,
ContainerName,
Container(..),
HasImage(..),
dns,
hostname,
Publishable,
publish,
expose,
user,
Mountable,
volume,
volumes_from,
workdir,
memory,
cpuShares,
link,
environment,
ContainerAlias,
restartAlways,
restartOnFailure,
restartNever,
init,
chain,
) where
import Propellor.Base hiding (init)
import Propellor.Types.Docker
import Propellor.Types.Container
import Propellor.Types.Core
import Propellor.Types.CmdLine
import Propellor.Types.Info
import Propellor.Container
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Cmd as Cmd
import qualified Propellor.Property.Pacman as Pacman
import qualified Propellor.Shim as Shim
import Utility.Path
import Utility.ThreadScheduler
import Utility.Split
import Control.Concurrent.Async hiding (link)
import System.Posix.Directory
import System.Posix.Process
import Prelude hiding (init)
import Data.List hiding (init)
import qualified Data.Map as M
import System.Console.Concurrent
installed :: Property (DebianLike + ArchLinux)
installed :: Property (DebianLike + ArchLinux)
installed = [ContainerName] -> Property DebianLike
Apt.installed [ContainerName
"docker.io"] Property DebianLike -> Property ArchLinux -> Property Linux
forall {k} ka kb (c :: k) (a :: ka) (b :: kb).
(HasCallStack, SingKind 'KProxy, SingKind 'KProxy,
DemoteRep 'KProxy ~ [MetaType], DemoteRep 'KProxy ~ [MetaType],
SingI c) =>
Property (MetaTypes a)
-> Property (MetaTypes b) -> Property (MetaTypes c)
`pickOS` [ContainerName] -> Property ArchLinux
Pacman.installed [ContainerName
"docker"]
configured :: Property (HasInfo + DebianLike)
configured :: Property (HasInfo + DebianLike)
configured = Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
Property (HasInfo + DebianLike)
prop Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
-> Property Linux
-> CombinedType
(Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
(Property Linux)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property Linux
Property (DebianLike + ArchLinux)
installed
where
prop :: Property (HasInfo + DebianLike)
prop :: Property (HasInfo + DebianLike)
prop = PrivDataSource
-> Context
-> (((PrivData -> Propellor Result) -> Propellor Result)
-> Property (HasInfo + DebianLike))
-> Property (HasInfo + DebianLike)
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 (HasInfo + DebianLike))
-> Property (HasInfo + DebianLike))
-> (((PrivData -> Propellor Result) -> Propellor Result)
-> Property (HasInfo + DebianLike))
-> Property (HasInfo + DebianLike)
forall a b. (a -> b) -> a -> b
$ \(PrivData -> Propellor Result) -> Propellor Result
getcfg ->
ContainerName
-> (OuterMetaTypesWitness
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
-> Propellor Result)
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' ContainerName
"docker configured" ((OuterMetaTypesWitness
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
-> Propellor Result)
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
-> (OuterMetaTypesWitness
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
-> Propellor Result)
-> Property
(MetaTypes
'[ '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 UnixLike -> 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 UnixLike -> Propellor Result)
-> Property UnixLike -> Propellor Result
forall a b. (a -> b) -> a -> b
$
ContainerName
"/root/.dockercfg" ContainerName -> [ContainerName] -> Property UnixLike
`File.hasContent` PrivData -> [ContainerName]
privDataLines PrivData
cfg
src :: PrivDataSource
src = PrivDataField -> ContainerName -> ContainerName -> PrivDataSource
PrivDataSourceFileFromCommand PrivDataField
DockerAuthentication
ContainerName
"/root/.dockercfg" ContainerName
"docker login"
type ContainerName = String
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
container :: ContainerName -> Image -> Props metatypes -> Container
container :: forall metatypes.
ContainerName -> Image -> Props metatypes -> Container
container ContainerName
cn Image
image (Props [ChildProperty]
ps) = Image -> Host -> Container
Container Image
image (ContainerName -> [ChildProperty] -> Info -> Host
Host ContainerName
cn [ChildProperty]
ps Info
info)
where
info :: Info
info = DockerInfo -> Info
dockerInfo 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)
docked :: Container -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
docked :: Container -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
docked ctr :: Container
ctr@(Container Image
_ Host
h) =
(Container
-> Property (HasInfo + Linux) -> Property (HasInfo + Linux)
propagateContainerInfo Container
ctr (ContainerName
-> (ContainerId -> ContainerInfo -> Property Linux)
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
go ContainerName
"docked" ContainerId -> ContainerInfo -> Property Linux
setup))
Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
-> RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!>
(ContainerName
-> (ContainerId -> ContainerInfo -> Property Linux)
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
go ContainerName
"undocked" ContainerId -> ContainerInfo -> Property Linux
teardown)
where
cn :: ContainerName
cn = Host -> ContainerName
hostName Host
h
go :: ContainerName
-> (ContainerId -> ContainerInfo -> Property Linux)
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
go ContainerName
desc ContainerId -> ContainerInfo -> Property Linux
a = ContainerName
-> (OuterMetaTypesWitness
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
-> Propellor Result)
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' (ContainerName
desc ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
" " ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
cn) ((OuterMetaTypesWitness
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
-> Propellor Result)
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]))
-> (OuterMetaTypesWitness
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
-> Propellor Result)
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
w -> do
ContainerName
hn <- (Host -> ContainerName) -> Propellor ContainerName
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Host -> ContainerName
hostName
let cid :: ContainerId
cid = ContainerName -> ContainerName -> ContainerId
ContainerId ContainerName
hn ContainerName
cn
OuterMetaTypesWitness
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
-> Property Linux -> 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 Linux -> Propellor Result)
-> Property Linux -> Propellor Result
forall a b. (a -> b) -> a -> b
$ ContainerId -> ContainerInfo -> Property Linux
a ContainerId
cid (ContainerId -> Container -> ContainerInfo
mkContainerInfo ContainerId
cid Container
ctr)
setup :: ContainerId -> ContainerInfo -> Property Linux
setup :: ContainerId -> ContainerInfo -> Property Linux
setup ContainerId
cid (ContainerInfo Image
image [ContainerName]
runparams) =
ContainerId -> Property Linux
provisionContainer ContainerId
cid
Property Linux
-> Property Linux -> CombinedType (Property Linux) (Property Linux)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires`
ContainerId -> Image -> [ContainerName] -> Property Linux
runningContainer ContainerId
cid Image
image [ContainerName]
runparams
Property Linux
-> Property Linux -> CombinedType (Property Linux) (Property Linux)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires`
Property Linux
Property (DebianLike + ArchLinux)
installed
teardown :: ContainerId -> ContainerInfo -> Property Linux
teardown :: ContainerId -> ContainerInfo -> Property Linux
teardown ContainerId
cid (ContainerInfo Image
image [ContainerName]
_runparams) =
ContainerName -> Props Linux -> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
combineProperties (ContainerName
"undocked " ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerId -> ContainerName
fromContainerId ContainerId
cid) (Props Linux -> Property Linux) -> Props Linux -> Property Linux
forall a b. (a -> b) -> a -> b
$ [Property Linux] -> Props Linux
forall {k} (metatypes :: k).
[Property (MetaTypes metatypes)] -> Props (MetaTypes metatypes)
toProps
[ ContainerId -> Property Linux
stoppedContainer ContainerId
cid
, ContainerName -> Propellor Result -> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName -> Propellor Result -> Property (MetaTypes metatypes)
property (ContainerName
"cleaned up " ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerId -> ContainerName
fromContainerId ContainerId
cid) (Propellor Result -> Property Linux)
-> Propellor Result -> Property Linux
forall a b. (a -> b) -> a -> b
$
IO Result -> Propellor Result
forall a. IO a -> Propellor a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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
]
]
imageBuilt :: HasImage c => FilePath -> c -> Property Linux
imageBuilt :: forall c. HasImage c => ContainerName -> c -> Property Linux
imageBuilt ContainerName
directory c
ctr = Property Linux
built Property Linux -> ContainerName -> Property Linux
forall p. IsProp p => p -> ContainerName -> p
`describe` ContainerName
msg
where
msg :: ContainerName
msg = ContainerName
"docker image " ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ (Image -> ContainerName
forall i. ImageIdentifier i => i -> ContainerName
imageIdentifier Image
image) ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
" built from " ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
directory
built :: Property Linux
built :: Property Linux
built = Property UnixLike -> Property Linux
forall (untightened :: [MetaType]) (tightened :: [MetaType]).
(TightenTargetsAllowed untightened tightened, SingI tightened) =>
Property (MetaTypes untightened) -> Property (MetaTypes tightened)
forall (p :: * -> *) (untightened :: [MetaType])
(tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property UnixLike -> Property Linux)
-> Property UnixLike -> Property Linux
forall a b. (a -> b) -> a -> b
$
ContainerName
-> [ContainerName]
-> (CreateProcess -> CreateProcess)
-> UncheckedProperty UnixLike
Cmd.cmdProperty' ContainerName
dockercmd [ContainerName
"build", ContainerName
"--tag", Image -> ContainerName
forall i. ImageIdentifier i => i -> ContainerName
imageIdentifier Image
image, ContainerName
"./"] CreateProcess -> CreateProcess
workDir
UncheckedProperty UnixLike -> Result -> Property UnixLike
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
workDir :: CreateProcess -> CreateProcess
workDir CreateProcess
p = CreateProcess
p { cwd = Just directory }
image :: Image
image = c -> Image
forall a. HasImage a => a -> Image
getImageName c
ctr
imagePulled :: HasImage c => c -> Property Linux
imagePulled :: forall c. HasImage c => c -> Property Linux
imagePulled c
ctr = Property Linux
pulled Property Linux -> ContainerName -> Property Linux
forall p. IsProp p => p -> ContainerName -> p
`describe` ContainerName
msg
where
msg :: ContainerName
msg = ContainerName
"docker image " ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ (Image -> ContainerName
forall i. ImageIdentifier i => i -> ContainerName
imageIdentifier Image
image) ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
" pulled"
pulled :: Property Linux
pulled :: Property Linux
pulled = Property UnixLike -> Property Linux
forall (untightened :: [MetaType]) (tightened :: [MetaType]).
(TightenTargetsAllowed untightened tightened, SingI tightened) =>
Property (MetaTypes untightened) -> Property (MetaTypes tightened)
forall (p :: * -> *) (untightened :: [MetaType])
(tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property UnixLike -> Property Linux)
-> Property UnixLike -> Property Linux
forall a b. (a -> b) -> a -> b
$
ContainerName -> [ContainerName] -> UncheckedProperty UnixLike
Cmd.cmdProperty ContainerName
dockercmd [ContainerName
"pull", Image -> ContainerName
forall i. ImageIdentifier i => i -> ContainerName
imageIdentifier Image
image]
UncheckedProperty UnixLike -> Result -> Property UnixLike
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 + Linux) -> Property (HasInfo + Linux)
propagateContainerInfo ctr :: Container
ctr@(Container Image
_ Host
h) Property (HasInfo + Linux)
p =
ContainerName
-> Container
-> (PropagateInfo -> Bool)
-> Property (HasInfo + Linux)
-> Property (HasInfo + Linux)
forall metatypes c.
(IncludesInfo metatypes ~ 'True, IsContainer c) =>
ContainerName
-> c
-> (PropagateInfo -> Bool)
-> Property metatypes
-> Property metatypes
propagateContainer ContainerName
cn Container
ctr PropagateInfo -> Bool
normalContainerInfo (Property (HasInfo + Linux) -> Property (HasInfo + Linux))
-> Property (HasInfo + Linux) -> Property (HasInfo + Linux)
forall a b. (a -> b) -> a -> b
$
Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
Property (HasInfo + Linux)
p Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
-> Info
-> Property
(MetaTypes
'[ '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 = M.singleton cn h }
cn :: ContainerName
cn = Host -> ContainerName
hostName Host
h
mkContainerInfo :: ContainerId -> Container -> ContainerInfo
mkContainerInfo :: ContainerId -> Container -> ContainerInfo
mkContainerInfo cid :: ContainerId
cid@(ContainerId ContainerName
hn ContainerName
_cn) (Container Image
img Host
h) =
Image -> [ContainerName] -> ContainerInfo
ContainerInfo Image
img [ContainerName]
runparams
where
runparams :: [ContainerName]
runparams = (DockerRunParam -> ContainerName)
-> [DockerRunParam] -> [ContainerName]
forall a b. (a -> b) -> [a] -> [b]
map (\(DockerRunParam ContainerName -> ContainerName
mkparam) -> ContainerName -> ContainerName
mkparam ContainerName
hn)
(DockerInfo -> [DockerRunParam]
_dockerRunParams DockerInfo
info)
info :: DockerInfo
info = 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
(MetaTypes
(Combine
(Combine
(Combine
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]))
-> Host
forall c metatypes. IsContainer c => c -> Props metatypes -> c
setContainerProps Host
h (Props
(MetaTypes
(Combine
(Combine
(Combine
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]))
-> Host)
-> Props
(MetaTypes
(Combine
(Combine
(Combine
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]))
-> Host
forall a b. (a -> b) -> a -> b
$ Host -> Props UnixLike
forall c. IsContainer c => c -> Props UnixLike
containerProps Host
h
Props UnixLike
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
-> Props
(Sing
(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
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
Property (HasInfo + Linux)
restartAlways
Props
(Sing
(Combine
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]))
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
-> Props
(Sing
(Combine
(Combine
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
'[ '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))
& ContainerName -> Property (HasInfo + Linux)
forall v. Mountable v => v -> Property (HasInfo + Linux)
volume (ContainerName
localdirContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ContainerName
":"ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ContainerName
localdir)
Props
(Sing
(Combine
(Combine
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]))
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
-> Props
(MetaTypes
(Combine
(Combine
(Combine
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
'[ '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))
& ContainerName -> Property (HasInfo + Linux)
name (ContainerId -> ContainerName
fromContainerId ContainerId
cid)
garbageCollected :: Property Linux
garbageCollected :: Property Linux
garbageCollected = ContainerName -> Props Linux -> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
propertyList ContainerName
"docker garbage collected" (Props Linux -> Property Linux) -> Props Linux -> Property Linux
forall a b. (a -> b) -> a -> b
$ Props UnixLike
props
Props UnixLike
-> Property Linux
-> 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 Linux
gccontainers
Props Linux
-> Property Linux
-> 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 Linux
gcimages
where
gccontainers :: Property Linux
gccontainers :: Property Linux
gccontainers = ContainerName -> Propellor Result -> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName -> Propellor Result -> Property (MetaTypes metatypes)
property ContainerName
"docker containers garbage collected" (Propellor Result -> Property Linux)
-> Propellor Result -> Property Linux
forall a b. (a -> b) -> a -> b
$
IO Result -> Propellor Result
forall a. IO a -> Propellor a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 Linux
gcimages = ContainerName -> Propellor Result -> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName -> Propellor Result -> Property (MetaTypes metatypes)
property ContainerName
"docker images garbage collected" (Propellor Result -> Property Linux)
-> Propellor Result -> Property Linux
forall a b. (a -> b) -> a -> b
$
IO Result -> Propellor Result
forall a. IO a -> Propellor a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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)
tweaked :: Property Linux
tweaked :: Property Linux
tweaked = Property UnixLike -> Property Linux
forall (untightened :: [MetaType]) (tightened :: [MetaType]).
(TightenTargetsAllowed untightened tightened, SingI tightened) =>
Property (MetaTypes untightened) -> Property (MetaTypes tightened)
forall (p :: * -> *) (untightened :: [MetaType])
(tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property UnixLike -> Property Linux)
-> Property UnixLike -> Property Linux
forall a b. (a -> b) -> a -> b
$ ContainerName -> [ContainerName] -> UncheckedProperty UnixLike
cmdProperty ContainerName
"sh"
[ ContainerName
"-c"
, ContainerName
"sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"
]
UncheckedProperty UnixLike -> Result -> Property UnixLike
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
NoChange
Property UnixLike -> ContainerName -> Property UnixLike
forall p. IsProp p => p -> ContainerName -> p
`describe` ContainerName
"tweaked for docker"
memoryLimited :: Property DebianLike
memoryLimited :: Property DebianLike
memoryLimited = Property UnixLike -> Property DebianLike
forall (untightened :: [MetaType]) (tightened :: [MetaType]).
(TightenTargetsAllowed untightened tightened, SingI tightened) =>
Property (MetaTypes untightened) -> Property (MetaTypes tightened)
forall (p :: * -> *) (untightened :: [MetaType])
(tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property UnixLike -> Property DebianLike)
-> Property UnixLike -> Property DebianLike
forall a b. (a -> b) -> a -> b
$
ContainerName
"/etc/default/grub" ContainerName -> ContainerName -> Property UnixLike
`File.containsLine` ContainerName
cfg
Property UnixLike -> ContainerName -> Property UnixLike
forall p. IsProp p => p -> ContainerName -> p
`describe` ContainerName
"docker memory limited"
Property UnixLike
-> Property UnixLike
-> CombinedType (Property UnixLike) (Property UnixLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` (ContainerName -> [ContainerName] -> UncheckedProperty UnixLike
cmdProperty ContainerName
"update-grub" [] UncheckedProperty UnixLike -> Result -> Property UnixLike
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange)
where
cmdline :: ContainerName
cmdline = ContainerName
"cgroup_enable=memory swapaccount=1"
cfg :: ContainerName
cfg = ContainerName
"GRUB_CMDLINE_LINUX_DEFAULT=\""ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ContainerName
cmdlineContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ContainerName
"\""
data ContainerInfo = ContainerInfo Image [RunParam]
type RunParam = String
newtype ImageID = ImageID String
class ImageIdentifier i where
toImageID :: i -> ImageID
toImageID = ContainerName -> ImageID
ImageID (ContainerName -> ImageID) -> (i -> ContainerName) -> i -> ImageID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> ContainerName
forall i. ImageIdentifier i => i -> ContainerName
imageIdentifier
imageIdentifier :: i -> String
instance ImageIdentifier ImageID where
imageIdentifier :: ImageID -> ContainerName
imageIdentifier (ImageID ContainerName
i) = ContainerName
i
toImageID :: ImageID -> ImageID
toImageID = ImageID -> ImageID
forall a. a -> a
id
data Image = Image
{ Image -> ContainerName
repository :: String
, Image -> Maybe ContainerName
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
$c== :: Image -> Image -> Bool
== :: Image -> Image -> Bool
$c/= :: Image -> Image -> Bool
/= :: 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
$creadsPrec :: Int -> ReadS Image
readsPrec :: Int -> ReadS Image
$creadList :: ReadS [Image]
readList :: ReadS [Image]
$creadPrec :: ReadPrec Image
readPrec :: ReadPrec Image
$creadListPrec :: ReadPrec [Image]
readListPrec :: ReadPrec [Image]
Read, Int -> Image -> ContainerName -> ContainerName
[Image] -> ContainerName -> ContainerName
Image -> ContainerName
(Int -> Image -> ContainerName -> ContainerName)
-> (Image -> ContainerName)
-> ([Image] -> ContainerName -> ContainerName)
-> Show Image
forall a.
(Int -> a -> ContainerName -> ContainerName)
-> (a -> ContainerName)
-> ([a] -> ContainerName -> ContainerName)
-> Show a
$cshowsPrec :: Int -> Image -> ContainerName -> ContainerName
showsPrec :: Int -> Image -> ContainerName -> ContainerName
$cshow :: Image -> ContainerName
show :: Image -> ContainerName
$cshowList :: [Image] -> ContainerName -> ContainerName
showList :: [Image] -> ContainerName -> ContainerName
Show)
latestImage :: String -> Image
latestImage :: ContainerName -> Image
latestImage ContainerName
repo = ContainerName -> Maybe ContainerName -> Image
Image ContainerName
repo Maybe ContainerName
forall a. Maybe a
Nothing
instance ImageIdentifier Image where
imageIdentifier :: Image -> ContainerName
imageIdentifier Image
i = Image -> ContainerName
repository Image
i ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ (ContainerName
-> (ContainerName -> ContainerName)
-> Maybe ContainerName
-> ContainerName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ContainerName
"" (ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
(++) ContainerName
":") (Maybe ContainerName -> ContainerName)
-> Maybe ContainerName -> ContainerName
forall a b. (a -> b) -> a -> b
$ Image -> Maybe ContainerName
tag Image
i)
newtype ImageUID = ImageUID String
instance ImageIdentifier ImageUID where
imageIdentifier :: ImageUID -> ContainerName
imageIdentifier (ImageUID ContainerName
uid) = ContainerName
uid
dns :: String -> Property (HasInfo + Linux)
dns :: ContainerName -> Property (HasInfo + Linux)
dns = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"dns"
hostname :: String -> Property (HasInfo + Linux)
hostname :: ContainerName -> Property (HasInfo + Linux)
hostname = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"hostname"
name :: String -> Property (HasInfo + Linux)
name :: ContainerName -> Property (HasInfo + Linux)
name = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"name"
class Publishable p where
toPublish :: p -> String
instance Publishable (Bound Port) where
toPublish :: Bound Port -> ContainerName
toPublish Bound Port
p = Port -> ContainerName
forall t. ConfigurableValue t => t -> ContainerName
val (Bound Port -> Port
forall v. Bound v -> v
hostSide Bound Port
p) ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
":" ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ Port -> ContainerName
forall t. ConfigurableValue t => t -> ContainerName
val (Bound Port -> Port
forall v. Bound v -> v
containerSide Bound Port
p)
instance Publishable String where
toPublish :: ContainerName -> ContainerName
toPublish = ContainerName -> ContainerName
forall a. a -> a
id
publish :: Publishable p => p -> Property (HasInfo + Linux)
publish :: forall p. Publishable p => p -> Property (HasInfo + Linux)
publish = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"publish" (ContainerName
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]))
-> (p -> ContainerName)
-> p
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> ContainerName
forall p. Publishable p => p -> ContainerName
toPublish
expose :: String -> Property (HasInfo + Linux)
expose :: ContainerName -> Property (HasInfo + Linux)
expose = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"expose"
user :: String -> Property (HasInfo + Linux)
user :: ContainerName -> Property (HasInfo + Linux)
user = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"user"
class Mountable p where
toMount :: p -> String
instance Mountable (Bound FilePath) where
toMount :: Bound ContainerName -> ContainerName
toMount Bound ContainerName
p = Bound ContainerName -> ContainerName
forall v. Bound v -> v
hostSide Bound ContainerName
p ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
":" ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ Bound ContainerName -> ContainerName
forall v. Bound v -> v
containerSide Bound ContainerName
p
instance Mountable String where
toMount :: ContainerName -> ContainerName
toMount = ContainerName -> ContainerName
forall a. a -> a
id
volume :: Mountable v => v -> Property (HasInfo + Linux)
volume :: forall v. Mountable v => v -> Property (HasInfo + Linux)
volume = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"volume" (ContainerName
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]))
-> (v -> ContainerName)
-> v
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> ContainerName
forall p. Mountable p => p -> ContainerName
toMount
volumes_from :: ContainerName -> Property (HasInfo + Linux)
volumes_from :: ContainerName -> Property (HasInfo + Linux)
volumes_from ContainerName
cn = ContainerName
-> (ContainerName -> ContainerName) -> Property (HasInfo + Linux)
genProp ContainerName
"volumes-from" ((ContainerName -> ContainerName) -> Property (HasInfo + Linux))
-> (ContainerName -> ContainerName) -> Property (HasInfo + Linux)
forall a b. (a -> b) -> a -> b
$ \ContainerName
hn ->
ContainerId -> ContainerName
fromContainerId (ContainerName -> ContainerName -> ContainerId
ContainerId ContainerName
hn ContainerName
cn)
workdir :: String -> Property (HasInfo + Linux)
workdir :: ContainerName -> Property (HasInfo + Linux)
workdir = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"workdir"
memory :: String -> Property (HasInfo + Linux)
memory :: ContainerName -> Property (HasInfo + Linux)
memory = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"memory"
cpuShares :: Int -> Property (HasInfo + Linux)
cpuShares :: Int -> Property (HasInfo + Linux)
cpuShares = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"cpu-shares" (ContainerName
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]))
-> (Int -> ContainerName)
-> Int
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ContainerName
forall a. Show a => a -> ContainerName
show
link :: ContainerName -> ContainerAlias -> Property (HasInfo + Linux)
link :: ContainerName -> ContainerName -> Property (HasInfo + Linux)
link ContainerName
linkwith ContainerName
calias = ContainerName
-> (ContainerName -> ContainerName) -> Property (HasInfo + Linux)
genProp ContainerName
"link" ((ContainerName -> ContainerName) -> Property (HasInfo + Linux))
-> (ContainerName -> ContainerName) -> Property (HasInfo + Linux)
forall a b. (a -> b) -> a -> b
$ \ContainerName
hn ->
ContainerId -> ContainerName
fromContainerId (ContainerName -> ContainerName -> ContainerId
ContainerId ContainerName
hn ContainerName
linkwith) ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
":" ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
calias
type ContainerAlias = String
restartAlways :: Property (HasInfo + Linux)
restartAlways :: Property (HasInfo + Linux)
restartAlways = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"restart" ContainerName
"always"
restartOnFailure :: Maybe Int -> Property (HasInfo + Linux)
restartOnFailure :: Maybe Int -> Property (HasInfo + Linux)
restartOnFailure Maybe Int
Nothing = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"restart" ContainerName
"on-failure"
restartOnFailure (Just Int
n) = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"restart" (ContainerName
"on-failure:" ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ Int -> ContainerName
forall a. Show a => a -> ContainerName
show Int
n)
restartNever :: Property (HasInfo + Linux)
restartNever :: Property (HasInfo + Linux)
restartNever = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"restart" ContainerName
"no"
environment :: (String, String) -> Property (HasInfo + Linux)
environment :: (ContainerName, ContainerName) -> Property (HasInfo + Linux)
environment (ContainerName
k, ContainerName
v) = ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
"env" (ContainerName -> Property (HasInfo + Linux))
-> ContainerName -> Property (HasInfo + Linux)
forall a b. (a -> b) -> a -> b
$ ContainerName
k ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
"=" ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
v
data ContainerId = ContainerId
{ ContainerId -> ContainerName
containerHostName :: HostName
, ContainerId -> ContainerName
containerName :: ContainerName
}
deriving (ContainerId -> ContainerId -> Bool
(ContainerId -> ContainerId -> Bool)
-> (ContainerId -> ContainerId -> Bool) -> Eq ContainerId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ContainerId -> ContainerId -> Bool
== :: ContainerId -> ContainerId -> Bool
$c/= :: ContainerId -> ContainerId -> Bool
/= :: 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
$creadsPrec :: Int -> ReadS ContainerId
readsPrec :: Int -> ReadS ContainerId
$creadList :: ReadS [ContainerId]
readList :: ReadS [ContainerId]
$creadPrec :: ReadPrec ContainerId
readPrec :: ReadPrec ContainerId
$creadListPrec :: ReadPrec [ContainerId]
readListPrec :: ReadPrec [ContainerId]
Read, Int -> ContainerId -> ContainerName -> ContainerName
[ContainerId] -> ContainerName -> ContainerName
ContainerId -> ContainerName
(Int -> ContainerId -> ContainerName -> ContainerName)
-> (ContainerId -> ContainerName)
-> ([ContainerId] -> ContainerName -> ContainerName)
-> Show ContainerId
forall a.
(Int -> a -> ContainerName -> ContainerName)
-> (a -> ContainerName)
-> ([a] -> ContainerName -> ContainerName)
-> Show a
$cshowsPrec :: Int -> ContainerId -> ContainerName -> ContainerName
showsPrec :: Int -> ContainerId -> ContainerName -> ContainerName
$cshow :: ContainerId -> ContainerName
show :: ContainerId -> ContainerName
$cshowList :: [ContainerId] -> ContainerName -> ContainerName
showList :: [ContainerId] -> ContainerName -> ContainerName
Show)
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
$creadsPrec :: Int -> ReadS ContainerIdent
readsPrec :: Int -> ReadS ContainerIdent
$creadList :: ReadS [ContainerIdent]
readList :: ReadS [ContainerIdent]
$creadPrec :: ReadPrec ContainerIdent
readPrec :: ReadPrec ContainerIdent
$creadListPrec :: ReadPrec [ContainerIdent]
readListPrec :: ReadPrec [ContainerIdent]
Read, Int -> ContainerIdent -> ContainerName -> ContainerName
[ContainerIdent] -> ContainerName -> ContainerName
ContainerIdent -> ContainerName
(Int -> ContainerIdent -> ContainerName -> ContainerName)
-> (ContainerIdent -> ContainerName)
-> ([ContainerIdent] -> ContainerName -> ContainerName)
-> Show ContainerIdent
forall a.
(Int -> a -> ContainerName -> ContainerName)
-> (a -> ContainerName)
-> ([a] -> ContainerName -> ContainerName)
-> Show a
$cshowsPrec :: Int -> ContainerIdent -> ContainerName -> ContainerName
showsPrec :: Int -> ContainerIdent -> ContainerName -> ContainerName
$cshow :: ContainerIdent -> ContainerName
show :: ContainerIdent -> ContainerName
$cshowList :: [ContainerIdent] -> ContainerName -> ContainerName
showList :: [ContainerIdent] -> ContainerName -> ContainerName
Show, ContainerIdent -> ContainerIdent -> Bool
(ContainerIdent -> ContainerIdent -> Bool)
-> (ContainerIdent -> ContainerIdent -> Bool) -> Eq ContainerIdent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ContainerIdent -> ContainerIdent -> Bool
== :: ContainerIdent -> ContainerIdent -> Bool
$c/= :: ContainerIdent -> ContainerIdent -> Bool
/= :: ContainerIdent -> ContainerIdent -> Bool
Eq)
toContainerId :: String -> Maybe ContainerId
toContainerId :: ContainerName -> Maybe ContainerId
toContainerId ContainerName
s
| ContainerName
myContainerSuffix ContainerName -> ContainerName -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` ContainerName
s = case (Char -> Bool) -> ContainerName -> (ContainerName, ContainerName)
forall a. (a -> Bool) -> [a] -> ([a], [a])
separate (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') (ContainerName -> ContainerName
forall {a}. [a] -> [a]
desuffix ContainerName
s) of
(ContainerName
cn, ContainerName
hn)
| ContainerName -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ContainerName
hn Bool -> Bool -> Bool
|| ContainerName -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ContainerName
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
$ ContainerName -> ContainerName -> ContainerId
ContainerId ContainerName
hn ContainerName
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 = ContainerName -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ContainerName
myContainerSuffix
fromContainerId :: ContainerId -> String
fromContainerId :: ContainerId -> ContainerName
fromContainerId (ContainerId ContainerName
hn ContainerName
cn) = ContainerName
cnContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ContainerName
"."ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ContainerName
hnContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ContainerName
myContainerSuffix
myContainerSuffix :: String
myContainerSuffix :: ContainerName
myContainerSuffix = ContainerName
".propellor"
containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i
containerDesc :: forall i.
IsProp (Property i) =>
ContainerId -> Property i -> Property i
containerDesc ContainerId
cid Property i
p = Property i
p Property i -> ContainerName -> Property i
forall p. IsProp p => p -> ContainerName -> p
`describe` ContainerName
desc
where
desc :: ContainerName
desc = ContainerName
"container " ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerId -> ContainerName
fromContainerId ContainerId
cid ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
" " ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ Property i -> ContainerName
forall p. IsProp p => p -> ContainerName
getDesc Property i
p
runningContainer :: ContainerId -> Image -> [RunParam] -> Property Linux
runningContainer :: ContainerId -> Image -> [ContainerName] -> Property Linux
runningContainer cid :: ContainerId
cid@(ContainerId ContainerName
hn ContainerName
cn) Image
image [ContainerName]
runps = ContainerId -> Property Linux -> Property Linux
forall i.
IsProp (Property i) =>
ContainerId -> Property i -> Property i
containerDesc ContainerId
cid (Property Linux -> Property Linux)
-> Property Linux -> Property Linux
forall a b. (a -> b) -> a -> b
$ ContainerName -> Propellor Result -> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName -> Propellor Result -> Property (MetaTypes metatypes)
property ContainerName
"running" (Propellor Result -> Property Linux)
-> Propellor Result -> Property Linux
forall a b. (a -> b) -> a -> b
$ do
[ContainerId]
l <- IO [ContainerId] -> Propellor [ContainerId]
forall a. IO a -> Propellor a
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 a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ContainerId]
l
then Either ContainerName (Maybe ContainerIdent) -> Propellor Result
checkident (Either ContainerName (Maybe ContainerIdent) -> Propellor Result)
-> Propellor (Either ContainerName (Maybe ContainerIdent))
-> Propellor Result
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either ContainerName (Maybe ContainerIdent))
-> Propellor (Either ContainerName (Maybe ContainerIdent))
forall a. IO a -> Propellor a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Either ContainerName (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 a. IO a -> Propellor a
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 a. Eq a => a -> [a] -> 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
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 a. IO a -> Propellor a
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
Either ContainerName (Maybe ContainerIdent) -> Propellor Result
checkident (Either ContainerName (Maybe ContainerIdent) -> Propellor Result)
-> Propellor (Either ContainerName (Maybe ContainerIdent))
-> Propellor Result
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either ContainerName (Maybe ContainerIdent))
-> Propellor (Either ContainerName (Maybe ContainerIdent))
forall a. IO a -> Propellor a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int
-> IO (Either ContainerName (Maybe ContainerIdent))
-> IO (Either ContainerName (Maybe ContainerIdent))
forall e a.
Int -> IO (Either e (Maybe a)) -> IO (Either e (Maybe a))
retry Int
60 (IO (Either ContainerName (Maybe ContainerIdent))
-> IO (Either ContainerName (Maybe ContainerIdent)))
-> IO (Either ContainerName (Maybe ContainerIdent))
-> IO (Either ContainerName (Maybe ContainerIdent))
forall a b. (a -> b) -> a -> b
$ IO (Either ContainerName (Maybe ContainerIdent))
getrunningident)
, Image -> Propellor Result
forall i. ImageIdentifier i => i -> Propellor Result
go Image
image
)
where
ident :: ContainerIdent
ident = Image
-> ContainerName
-> ContainerName
-> [ContainerName]
-> ContainerIdent
ContainerIdent Image
image ContainerName
hn ContainerName
cn [ContainerName]
runps
checkident :: Either ContainerName (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 a. IO a -> Propellor a
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 ContainerName
errmsg) = do
ContainerName -> Propellor ()
forall (m :: * -> *). MonadIO m => ContainerName -> m ()
warningMessage ContainerName
errmsg
Result -> Propellor Result
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
restartcontainer :: Propellor Result
restartcontainer = do
ImageID
oldimage <- IO ImageID -> Propellor ImageID
forall a. IO a -> Propellor a
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 a. IO a -> Propellor a
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 ContainerName (Maybe ContainerIdent))
getrunningident = ContainerName
-> (ContainerName
-> Handle -> IO (Either ContainerName (Maybe ContainerIdent)))
-> IO (Either ContainerName (Maybe ContainerIdent))
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ContainerName -> (ContainerName -> Handle -> m a) -> m a
withTmpFile ContainerName
"dockerrunsane" ((ContainerName
-> Handle -> IO (Either ContainerName (Maybe ContainerIdent)))
-> IO (Either ContainerName (Maybe ContainerIdent)))
-> (ContainerName
-> Handle -> IO (Either ContainerName (Maybe ContainerIdent)))
-> IO (Either ContainerName (Maybe ContainerIdent))
forall a b. (a -> b) -> a -> b
$ \ContainerName
t Handle
h -> do
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 -> [ContainerName] -> [ContainerName] -> CreateProcess
inContainerProcess ContainerId
cid []
[ContainerName
"rm", ContainerName
"-f", ContainerName
t])
IO Bool
-> (IO (Either ContainerName (Maybe ContainerIdent)),
IO (Either ContainerName (Maybe ContainerIdent)))
-> IO (Either ContainerName (Maybe ContainerIdent))
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (ContainerName -> IO Bool
doesFileExist ContainerName
t)
( Maybe ContainerIdent -> Either ContainerName (Maybe ContainerIdent)
forall a b. b -> Either a b
Right (Maybe ContainerIdent
-> Either ContainerName (Maybe ContainerIdent))
-> (ContainerName -> Maybe ContainerIdent)
-> ContainerName
-> Either ContainerName (Maybe ContainerIdent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContainerName -> Maybe ContainerIdent
forall a. Read a => ContainerName -> Maybe a
readish (ContainerName -> Either ContainerName (Maybe ContainerIdent))
-> IO ContainerName
-> IO (Either ContainerName (Maybe ContainerIdent))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
CreateProcess -> IO ContainerName
readProcess' (ContainerId -> [ContainerName] -> [ContainerName] -> CreateProcess
inContainerProcess ContainerId
cid []
[ContainerName
"cat", ContainerName
propellorIdent])
, Either ContainerName (Maybe ContainerIdent)
-> IO (Either ContainerName (Maybe ContainerIdent))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ContainerName (Maybe ContainerIdent)
-> IO (Either ContainerName (Maybe ContainerIdent)))
-> Either ContainerName (Maybe ContainerIdent)
-> IO (Either ContainerName (Maybe ContainerIdent))
forall a b. (a -> b) -> a -> b
$ ContainerName -> Either ContainerName (Maybe ContainerIdent)
forall a b. a -> Either a b
Left ContainerName
"docker exec failed to enter chroot properly (maybe an old kernel version?)"
)
retry :: Int -> IO (Either e (Maybe a)) -> IO (Either e (Maybe a))
retry :: forall e a.
Int -> IO (Either e (Maybe a)) -> IO (Either e (Maybe a))
retry Int
0 IO (Either e (Maybe a))
_ = Either e (Maybe a) -> IO (Either e (Maybe a))
forall a. a -> IO 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either e (Maybe a)
v
go :: ImageIdentifier i => i -> Propellor Result
go :: forall i. ImageIdentifier i => i -> Propellor Result
go i
img = IO Result -> Propellor Result
forall a. IO a -> Propellor a
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 -> ContainerName -> IO ()
createDirectoryIfMissing Bool
True (ContainerName -> ContainerName
takeDirectory (ContainerName -> ContainerName) -> ContainerName -> ContainerName
forall a b. (a -> b) -> a -> b
$ ContainerId -> ContainerName
identFile ContainerId
cid)
ContainerName
shim <- ContainerName
-> Maybe ContainerName -> ContainerName -> IO ContainerName
Shim.setup (ContainerName
localdir ContainerName -> ContainerName -> ContainerName
</> ContainerName
"propellor") Maybe ContainerName
forall a. Maybe a
Nothing (ContainerName
localdir ContainerName -> ContainerName -> ContainerName
</> ContainerId -> ContainerName
shimdir ContainerId
cid)
ContainerName -> ContainerName -> IO ()
writeFile (ContainerId -> ContainerName
identFile ContainerId
cid) (ContainerIdent -> ContainerName
forall a. Show a => a -> ContainerName
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 -> [ContainerName] -> [ContainerName] -> IO Bool
forall i.
ImageIdentifier i =>
i -> [ContainerName] -> [ContainerName] -> IO Bool
runContainer i
img
([ContainerName]
runps [ContainerName] -> [ContainerName] -> [ContainerName]
forall a. [a] -> [a] -> [a]
++ [ContainerName
"-i", ContainerName
"-d", ContainerName
"-t"])
[ContainerName
shim, ContainerName
"--continue", CmdLine -> ContainerName
forall a. Show a => a -> ContainerName
show (ContainerName -> CmdLine
DockerInit (ContainerId -> ContainerName
fromContainerId ContainerId
cid))]
init :: String -> IO ()
init :: ContainerName -> IO ()
init ContainerName
s = case ContainerName -> Maybe ContainerId
toContainerId ContainerName
s of
Maybe ContainerId
Nothing -> ContainerName -> IO ()
forall a. HasCallStack => ContainerName -> a
error (ContainerName -> IO ()) -> ContainerName -> IO ()
forall a b. (a -> b) -> a -> b
$ ContainerName
"Invalid ContainerId: " ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
s
Just ContainerId
cid -> do
ContainerName -> IO ()
changeWorkingDirectory ContainerName
localdir
ContainerName -> ContainerName -> IO ()
writeFile ContainerName
propellorIdent (ContainerName -> IO ())
-> (ContainerIdent -> ContainerName) -> ContainerIdent -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContainerIdent -> ContainerName
forall a. Show a => a -> ContainerName
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 :: ContainerName
shim = ContainerName -> ContainerName -> ContainerName
Shim.file (ContainerName
localdir ContainerName -> ContainerName -> ContainerName
</> ContainerName
"propellor") (ContainerName
localdir ContainerName -> ContainerName -> ContainerName
</> ContainerId -> ContainerName
shimdir ContainerId
cid)
IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (ContainerName -> [CommandParam] -> IO Bool
boolSystem ContainerName
shim [ContainerName -> CommandParam
Param ContainerName
"--continue", ContainerName -> CommandParam
Param (ContainerName -> CommandParam) -> ContainerName -> CommandParam
forall a b. (a -> b) -> a -> b
$ CmdLine -> ContainerName
forall a. Show a => a -> ContainerName
show (CmdLine -> ContainerName) -> CmdLine -> ContainerName
forall a b. (a -> b) -> a -> b
$ ContainerId -> CmdLine
toChain ContainerId
cid]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
ContainerName -> IO ()
forall (m :: * -> *). MonadIO m => ContainerName -> m ()
warningMessage ContainerName
"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 (ContainerName -> IO Bool
inPath ContainerName
"bash")
( ContainerName -> [CommandParam] -> IO Bool
boolSystem ContainerName
"bash" [ContainerName -> CommandParam
Param ContainerName
"-l"]
, ContainerName -> [CommandParam] -> IO Bool
boolSystem ContainerName
"/bin/sh" []
)
ContainerName -> IO ()
putStrLn ContainerName
"Container is still running. Press ^P^Q to detach."
where
job :: IO a -> IO b
job = 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
provisionContainer :: ContainerId -> Property Linux
provisionContainer :: ContainerId -> Property Linux
provisionContainer ContainerId
cid = ContainerId -> Property Linux -> Property Linux
forall i.
IsProp (Property i) =>
ContainerId -> Property i -> Property i
containerDesc ContainerId
cid (Property Linux -> Property Linux)
-> Property Linux -> Property Linux
forall a b. (a -> b) -> a -> b
$ ContainerName -> Propellor Result -> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName -> Propellor Result -> Property (MetaTypes metatypes)
property ContainerName
"provisioned" (Propellor Result -> Property Linux)
-> Propellor Result -> Property Linux
forall a b. (a -> b) -> a -> b
$ IO Result -> Propellor Result
forall a. IO a -> Propellor a
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 :: ContainerName
shim = ContainerName -> ContainerName -> ContainerName
Shim.file (ContainerName
localdir ContainerName -> ContainerName -> ContainerName
</> ContainerName
"propellor") (ContainerName
localdir ContainerName -> ContainerName -> ContainerName
</> ContainerId -> ContainerName
shimdir ContainerId
cid)
let params :: [ContainerName]
params = [ContainerName
"--continue", CmdLine -> ContainerName
forall a. Show a => a -> ContainerName
show (CmdLine -> ContainerName) -> CmdLine -> ContainerName
forall a b. (a -> b) -> a -> b
$ ContainerId -> CmdLine
toChain ContainerId
cid]
MessageHandle
msgh <- IO MessageHandle
getMessageHandle
let p :: CreateProcess
p = ContainerId -> [ContainerName] -> [ContainerName] -> CreateProcess
inContainerProcess ContainerId
cid
(if MessageHandle -> Bool
isConsole MessageHandle
msgh then [ContainerName
"-it"] else [])
(ContainerName
shim ContainerName -> [ContainerName] -> [ContainerName]
forall a. a -> [a] -> [a]
: [ContainerName]
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
toChain :: ContainerId -> CmdLine
toChain :: ContainerId -> CmdLine
toChain ContainerId
cid = ContainerName -> ContainerName -> CmdLine
DockerChain (ContainerId -> ContainerName
containerHostName ContainerId
cid) (ContainerId -> ContainerName
fromContainerId ContainerId
cid)
chain :: [Host] -> HostName -> String -> IO ()
chain :: [Host] -> ContainerName -> ContainerName -> IO ()
chain [Host]
hostlist ContainerName
hn ContainerName
s = case ContainerName -> Maybe ContainerId
toContainerId ContainerName
s of
Maybe ContainerId
Nothing -> ContainerName -> IO ()
forall (m :: * -> *) a. MonadIO m => ContainerName -> m a
errorMessage ContainerName
"bad container id"
Just ContainerId
cid -> case [Host] -> ContainerName -> Maybe Host
findHostNoAlias [Host]
hostlist ContainerName
hn of
Maybe Host
Nothing -> ContainerName -> IO ()
forall (m :: * -> *) a. MonadIO m => ContainerName -> m a
errorMessage (ContainerName
"cannot find host " ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
hn)
Just Host
parenthost -> case ContainerName -> Map ContainerName Host -> Maybe Host
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ContainerId -> ContainerName
containerName ContainerId
cid) (DockerInfo -> Map ContainerName Host
_dockerContainers (DockerInfo -> Map ContainerName Host)
-> DockerInfo -> Map ContainerName 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 -> ContainerName -> IO ()
forall (m :: * -> *) a. MonadIO m => ContainerName -> m a
errorMessage (ContainerName
"cannot find container " ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerId -> ContainerName
containerName ContainerId
cid ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
" docked on host " ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
hn)
Just Host
h -> ContainerId -> Host -> IO ()
go ContainerId
cid Host
h
where
go :: ContainerId -> Host -> IO ()
go ContainerId
cid Host
h = do
ContainerName -> IO ()
changeWorkingDirectory ContainerName
localdir
ContainerName -> IO () -> IO ()
forall a. ContainerName -> IO a -> IO a
onlyProcess (ContainerId -> ContainerName
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 = hostInfo h `addInfo` [HostnameContained, FilesystemContained] }
stopContainer :: ContainerId -> IO Bool
stopContainer :: ContainerId -> IO Bool
stopContainer ContainerId
cid = ContainerName -> [CommandParam] -> IO Bool
boolSystem ContainerName
dockercmd [ContainerName -> CommandParam
Param ContainerName
"stop", ContainerName -> CommandParam
Param (ContainerName -> CommandParam) -> ContainerName -> CommandParam
forall a b. (a -> b) -> a -> b
$ ContainerId -> ContainerName
fromContainerId ContainerId
cid ]
startContainer :: ContainerId -> IO Bool
startContainer :: ContainerId -> IO Bool
startContainer ContainerId
cid = ContainerName -> [CommandParam] -> IO Bool
boolSystem ContainerName
dockercmd [ContainerName -> CommandParam
Param ContainerName
"start", ContainerName -> CommandParam
Param (ContainerName -> CommandParam) -> ContainerName -> CommandParam
forall a b. (a -> b) -> a -> b
$ ContainerId -> ContainerName
fromContainerId ContainerId
cid ]
stoppedContainer :: ContainerId -> Property Linux
stoppedContainer :: ContainerId -> Property Linux
stoppedContainer ContainerId
cid = ContainerId -> Property Linux -> Property Linux
forall i.
IsProp (Property i) =>
ContainerId -> Property i -> Property i
containerDesc ContainerId
cid (Property Linux -> Property Linux)
-> Property Linux -> Property Linux
forall a b. (a -> b) -> a -> b
$ ContainerName
-> (OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
-> Propellor Result)
-> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' ContainerName
desc ((OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
-> Propellor Result)
-> Property Linux)
-> (OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
-> Propellor Result)
-> Property Linux
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 a. IO a -> Propellor a
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 a. Eq a => a -> [a] -> 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 a. IO a -> Propellor a
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 Linux -> 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 Linux
stop
, Result -> Propellor Result
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
)
where
desc :: ContainerName
desc = ContainerName
"stopped"
stop :: Property Linux
stop :: Property Linux
stop = ContainerName -> Propellor Result -> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
ContainerName -> Propellor Result -> Property (MetaTypes metatypes)
property ContainerName
desc (Propellor Result -> Property Linux)
-> Propellor Result -> Property Linux
forall a b. (a -> b) -> a -> b
$ IO Result -> Propellor Result
forall a. IO a -> Propellor a
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
ContainerName -> IO ()
nukeFile (ContainerName -> IO ()) -> ContainerName -> IO ()
forall a b. (a -> b) -> a -> b
$ ContainerId -> ContainerName
identFile ContainerId
cid
ContainerName -> IO ()
removeDirectoryRecursive (ContainerName -> IO ()) -> ContainerName -> IO ()
forall a b. (a -> b) -> a -> b
$ ContainerId -> ContainerName
shimdir ContainerId
cid
ContainerId -> IO ()
clearProvisionedFlag ContainerId
cid
removeContainer :: ContainerId -> IO Bool
removeContainer :: ContainerId -> IO Bool
removeContainer ContainerId
cid = 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
$
(ContainerName, Bool) -> Bool
forall a b. (a, b) -> b
snd ((ContainerName, Bool) -> Bool)
-> IO (ContainerName, Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContainerName
-> [ContainerName]
-> Maybe ContainerName
-> IO (ContainerName, Bool)
processTranscript ContainerName
dockercmd [ContainerName
"rm", ContainerId -> ContainerName
fromContainerId ContainerId
cid ] Maybe ContainerName
forall a. Maybe a
Nothing
removeImage :: ImageIdentifier i => i -> IO Bool
removeImage :: forall i. ImageIdentifier i => 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
$
(ContainerName, Bool) -> Bool
forall a b. (a, b) -> b
snd ((ContainerName, Bool) -> Bool)
-> IO (ContainerName, Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContainerName
-> [ContainerName]
-> Maybe ContainerName
-> IO (ContainerName, Bool)
processTranscript ContainerName
dockercmd [ContainerName
"rmi", i -> ContainerName
forall i. ImageIdentifier i => i -> ContainerName
imageIdentifier i
image] Maybe ContainerName
forall a. Maybe a
Nothing
runContainer :: ImageIdentifier i => i -> [RunParam] -> [String] -> IO Bool
runContainer :: forall i.
ImageIdentifier i =>
i -> [ContainerName] -> [ContainerName] -> IO Bool
runContainer i
image [ContainerName]
ps [ContainerName]
cmd = ContainerName -> [CommandParam] -> IO Bool
boolSystem ContainerName
dockercmd ([CommandParam] -> IO Bool) -> [CommandParam] -> IO Bool
forall a b. (a -> b) -> a -> b
$ (ContainerName -> CommandParam)
-> [ContainerName] -> [CommandParam]
forall a b. (a -> b) -> [a] -> [b]
map ContainerName -> CommandParam
Param ([ContainerName] -> [CommandParam])
-> [ContainerName] -> [CommandParam]
forall a b. (a -> b) -> a -> b
$
ContainerName
"run" ContainerName -> [ContainerName] -> [ContainerName]
forall a. a -> [a] -> [a]
: ([ContainerName]
ps [ContainerName] -> [ContainerName] -> [ContainerName]
forall a. [a] -> [a] -> [a]
++ (i -> ContainerName
forall i. ImageIdentifier i => i -> ContainerName
imageIdentifier i
image) ContainerName -> [ContainerName] -> [ContainerName]
forall a. a -> [a] -> [a]
: [ContainerName]
cmd)
inContainerProcess :: ContainerId -> [String] -> [String] -> CreateProcess
inContainerProcess :: ContainerId -> [ContainerName] -> [ContainerName] -> CreateProcess
inContainerProcess ContainerId
cid [ContainerName]
ps [ContainerName]
cmd = ContainerName -> [ContainerName] -> CreateProcess
proc ContainerName
dockercmd (ContainerName
"exec" ContainerName -> [ContainerName] -> [ContainerName]
forall a. a -> [a] -> [a]
: [ContainerName]
ps [ContainerName] -> [ContainerName] -> [ContainerName]
forall a. [a] -> [a] -> [a]
++ [ContainerId -> ContainerName
fromContainerId ContainerId
cid] [ContainerName] -> [ContainerName] -> [ContainerName]
forall a. [a] -> [a] -> [a]
++ [ContainerName]
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
$
ContainerName -> ImageUID
ImageUID (ContainerName -> ImageUID)
-> (ContainerName -> ContainerName) -> ContainerName -> ImageUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ContainerName -> ContainerName
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')
(ContainerName -> ImageUID) -> IO ContainerName -> IO ImageUID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContainerName -> [ContainerName] -> IO ContainerName
readProcess ContainerName
dockercmd [ContainerName
"commit", ContainerId -> ContainerName
fromContainerId ContainerId
cid]
data ContainerFilter = RunningContainers | AllContainers
deriving (ContainerFilter -> ContainerFilter -> Bool
(ContainerFilter -> ContainerFilter -> Bool)
-> (ContainerFilter -> ContainerFilter -> Bool)
-> Eq ContainerFilter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ContainerFilter -> ContainerFilter -> Bool
== :: ContainerFilter -> ContainerFilter -> Bool
$c/= :: ContainerFilter -> ContainerFilter -> Bool
/= :: ContainerFilter -> ContainerFilter -> Bool
Eq)
listContainers :: ContainerFilter -> IO [ContainerId]
listContainers :: ContainerFilter -> IO [ContainerId]
listContainers ContainerFilter
status =
(ContainerName -> Maybe ContainerId)
-> [ContainerName] -> [ContainerId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ContainerName -> Maybe ContainerId
toContainerId ([ContainerName] -> [ContainerId])
-> (ContainerName -> [ContainerName])
-> ContainerName
-> [ContainerId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContainerName -> [ContainerName])
-> [ContainerName] -> [ContainerName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ContainerName -> ContainerName -> [ContainerName]
forall a. Eq a => [a] -> [a] -> [[a]]
split ContainerName
",")
([ContainerName] -> [ContainerName])
-> (ContainerName -> [ContainerName])
-> ContainerName
-> [ContainerName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContainerName -> Maybe ContainerName)
-> [ContainerName] -> [ContainerName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([ContainerName] -> Maybe ContainerName
forall a. [a] -> Maybe a
lastMaybe ([ContainerName] -> Maybe ContainerName)
-> (ContainerName -> [ContainerName])
-> ContainerName
-> Maybe ContainerName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContainerName -> [ContainerName]
words) ([ContainerName] -> [ContainerName])
-> (ContainerName -> [ContainerName])
-> ContainerName
-> [ContainerName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContainerName -> [ContainerName]
lines
(ContainerName -> [ContainerId])
-> IO ContainerName -> IO [ContainerId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContainerName -> [ContainerName] -> IO ContainerName
readProcess ContainerName
dockercmd [ContainerName]
ps
where
ps :: [ContainerName]
ps
| ContainerFilter
status ContainerFilter -> ContainerFilter -> Bool
forall a. Eq a => a -> a -> Bool
== ContainerFilter
AllContainers = [ContainerName]
baseps [ContainerName] -> [ContainerName] -> [ContainerName]
forall a. [a] -> [a] -> [a]
++ [ContainerName
"--all"]
| Bool
otherwise = [ContainerName]
baseps
baseps :: [ContainerName]
baseps = [ContainerName
"ps", ContainerName
"--no-trunc"]
listImages :: IO [ImageUID]
listImages :: IO [ImageUID]
listImages = (ContainerName -> ImageUID) -> [ContainerName] -> [ImageUID]
forall a b. (a -> b) -> [a] -> [b]
map ContainerName -> ImageUID
ImageUID ([ContainerName] -> [ImageUID])
-> (ContainerName -> [ContainerName])
-> ContainerName
-> [ImageUID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContainerName -> [ContainerName]
lines (ContainerName -> [ImageUID]) -> IO ContainerName -> IO [ImageUID]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContainerName -> [ContainerName] -> IO ContainerName
readProcess ContainerName
dockercmd [ContainerName
"images", ContainerName
"--all", ContainerName
"--quiet"]
runProp :: String -> RunParam -> Property (HasInfo + Linux)
runProp :: ContainerName -> ContainerName -> Property (HasInfo + Linux)
runProp ContainerName
field ContainerName
v = Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
forall (untightened :: [MetaType]) (tightened :: [MetaType]).
(TightenTargetsAllowed untightened tightened, SingI tightened) =>
Property (MetaTypes untightened) -> Property (MetaTypes tightened)
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
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]))
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ ContainerName -> DockerInfo -> Property (HasInfo + UnixLike)
forall v.
IsInfo v =>
ContainerName -> v -> Property (HasInfo + UnixLike)
pureInfoProperty (ContainerName
param) (DockerInfo -> Property (HasInfo + UnixLike))
-> DockerInfo -> Property (HasInfo + UnixLike)
forall a b. (a -> b) -> a -> b
$
DockerInfo
forall a. Monoid a => a
mempty { _dockerRunParams = [DockerRunParam (\ContainerName
_ -> ContainerName
"--"ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ContainerName
param)] }
where
param :: ContainerName
param = ContainerName
fieldContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ContainerName
"="ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ContainerName
v
genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux)
genProp :: ContainerName
-> (ContainerName -> ContainerName) -> Property (HasInfo + Linux)
genProp ContainerName
field ContainerName -> ContainerName
mkval = Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
forall (untightened :: [MetaType]) (tightened :: [MetaType]).
(TightenTargetsAllowed untightened tightened, SingI tightened) =>
Property (MetaTypes untightened) -> Property (MetaTypes tightened)
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
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]))
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ ContainerName -> DockerInfo -> Property (HasInfo + UnixLike)
forall v.
IsInfo v =>
ContainerName -> v -> Property (HasInfo + UnixLike)
pureInfoProperty ContainerName
field (DockerInfo -> Property (HasInfo + UnixLike))
-> DockerInfo -> Property (HasInfo + UnixLike)
forall a b. (a -> b) -> a -> b
$
DockerInfo
forall a. Monoid a => a
mempty { _dockerRunParams = [DockerRunParam (\ContainerName
hn -> ContainerName
"--"ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ContainerName
fieldContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ContainerName
"=" ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName -> ContainerName
mkval ContainerName
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
propellorIdent :: FilePath
propellorIdent :: ContainerName
propellorIdent = ContainerName
"/.propellor-ident"
provisionedFlag :: ContainerId -> FilePath
provisionedFlag :: ContainerId -> ContainerName
provisionedFlag ContainerId
cid = ContainerName
"docker" ContainerName -> ContainerName -> ContainerName
</> ContainerId -> ContainerName
fromContainerId ContainerId
cid ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
".provisioned"
clearProvisionedFlag :: ContainerId -> IO ()
clearProvisionedFlag :: ContainerId -> IO ()
clearProvisionedFlag = ContainerName -> IO ()
nukeFile (ContainerName -> IO ())
-> (ContainerId -> ContainerName) -> ContainerId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContainerId -> ContainerName
provisionedFlag
setProvisionedFlag :: ContainerId -> IO ()
setProvisionedFlag :: ContainerId -> IO ()
setProvisionedFlag ContainerId
cid = do
Bool -> ContainerName -> IO ()
createDirectoryIfMissing Bool
True (ContainerName -> ContainerName
takeDirectory (ContainerId -> ContainerName
provisionedFlag ContainerId
cid))
ContainerName -> ContainerName -> IO ()
writeFile (ContainerId -> ContainerName
provisionedFlag ContainerId
cid) ContainerName
"1"
checkProvisionedFlag :: ContainerId -> IO Bool
checkProvisionedFlag :: ContainerId -> IO Bool
checkProvisionedFlag = ContainerName -> IO Bool
doesFileExist (ContainerName -> IO Bool)
-> (ContainerId -> ContainerName) -> ContainerId -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContainerId -> ContainerName
provisionedFlag
provisioningLock :: ContainerId -> FilePath
provisioningLock :: ContainerId -> ContainerName
provisioningLock ContainerId
cid = ContainerName
"docker" ContainerName -> ContainerName -> ContainerName
</> ContainerId -> ContainerName
fromContainerId ContainerId
cid ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
".lock"
shimdir :: ContainerId -> FilePath
shimdir :: ContainerId -> ContainerName
shimdir ContainerId
cid = ContainerName
"docker" ContainerName -> ContainerName -> ContainerName
</> ContainerId -> ContainerName
fromContainerId ContainerId
cid ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
".shim"
identFile :: ContainerId -> FilePath
identFile :: ContainerId -> ContainerName
identFile ContainerId
cid = ContainerName
"docker" ContainerName -> ContainerName -> ContainerName
</> ContainerId -> ContainerName
fromContainerId ContainerId
cid ContainerName -> ContainerName -> ContainerName
forall a. [a] -> [a] -> [a]
++ ContainerName
".ident"
readIdentFile :: ContainerId -> IO ContainerIdent
readIdentFile :: ContainerId -> IO ContainerIdent
readIdentFile ContainerId
cid = ContainerIdent -> Maybe ContainerIdent -> ContainerIdent
forall a. a -> Maybe a -> a
fromMaybe (ContainerName -> ContainerIdent
forall a. HasCallStack => ContainerName -> a
error ContainerName
"bad ident in identFile")
(Maybe ContainerIdent -> ContainerIdent)
-> (ContainerName -> Maybe ContainerIdent)
-> ContainerName
-> ContainerIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContainerName -> Maybe ContainerIdent
forall a. Read a => ContainerName -> Maybe a
readish (ContainerName -> ContainerIdent)
-> IO ContainerName -> IO ContainerIdent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContainerName -> IO ContainerName
readFile (ContainerId -> ContainerName
identFile ContainerId
cid)
dockercmd :: String
dockercmd :: ContainerName
dockercmd = ContainerName
"docker"
report :: [Bool] -> Result
report :: [Bool] -> Result
report [Bool]
rmed
| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
rmed = Result
MadeChange
| Bool
otherwise = Result
NoChange