From 3a99c87cdfbbae4cfa31fff5e20c39bfcfdc0aae Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 24 May 2015 17:12:17 -0400 Subject: remove unnecessary use of ensureProperty --- src/Propellor/Property/Docker.hs | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) (limited to 'src/Propellor/Property/Docker.hs') diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index fdc312ce..3b8751f3 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -426,16 +426,14 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope retry (n-1) a _ -> return v - go img = do - liftIO $ do - clearProvisionedFlag cid - createDirectoryIfMissing True (takeDirectory $ identFile cid) - shim <- liftIO $ Shim.setup (localdir "propellor") Nothing (localdir shimdir cid) - liftIO $ writeFile (identFile cid) (show ident) - ensureProperty $ property "run" $ liftIO $ - toResult <$> runContainer img - (runps ++ ["-i", "-d", "-t"]) - [shim, "--continue", show (DockerInit (fromContainerId cid))] + go img = liftIO $ do + clearProvisionedFlag cid + createDirectoryIfMissing True (takeDirectory $ identFile cid) + shim <- Shim.setup (localdir "propellor") Nothing (localdir shimdir cid) + writeFile (identFile cid) (show ident) + toResult <$> runContainer img + (runps ++ ["-i", "-d", "-t"]) + [shim, "--continue", show (DockerInit (fromContainerId cid))] -- | Called when propellor is running inside a docker container. -- The string should be the container's ContainerId. -- cgit v1.2.3 From 626f1af56f12be63cd78fa4910c55453c23cf5a0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 27 May 2015 12:38:45 -0400 Subject: Export CommandParam, boolSystem, safeSystem and shellEscape from Propellor.Property.Cmd, so they are available for use in constricting your own Properties when using propellor as a library. Several imports of Utility.SafeCommand now redundant. --- debian/changelog | 3 ++ src/Propellor/Bootstrap.hs | 1 - src/Propellor/CmdLine.hs | 1 - src/Propellor/Git.hs | 1 - src/Propellor/Property/Apache.hs | 1 - src/Propellor/Property/Chroot.hs | 1 - src/Propellor/Property/Cmd.hs | 20 ++++++++-- src/Propellor/Property/Cron.hs | 1 - src/Propellor/Property/Debootstrap.hs | 1 - src/Propellor/Property/Docker.hs | 1 - src/Propellor/Property/Firewall.hs | 1 - src/Propellor/Property/Git.hs | 1 - src/Propellor/Property/Mount.hs | 1 - src/Propellor/Property/OS.hs | 1 - src/Propellor/Property/Obnam.hs | 1 - src/Propellor/Property/Reboot.hs | 1 - src/Propellor/Property/Service.hs | 1 - src/Propellor/Property/SiteSpecific/GitHome.hs | 1 - src/Propellor/Property/SiteSpecific/JoeySites.hs | 1 - src/Propellor/Property/Ssh.hs | 1 - src/Propellor/Property/Systemd.hs | 1 - src/Propellor/Shim.hs | 1 - src/Propellor/Ssh.hs | 1 - src/Utility/SafeCommand.hs | 49 ++++++++++++------------ 24 files changed, 43 insertions(+), 50 deletions(-) (limited to 'src/Propellor/Property/Docker.hs') diff --git a/debian/changelog b/debian/changelog index dc3b09de..96a9f745 100644 --- a/debian/changelog +++ b/debian/changelog @@ -4,6 +4,9 @@ propellor (2.5.0) UNRELEASED; urgency=medium more generic cmdProperty' (API change) * Add docker image related properties. Thanks, Antoine Eiche. + * Export CommandParam, boolSystem, safeSystem and shellEscape from + Propellor.Property.Cmd, so they are available for use in constricting + your own Properties when using propellor as a library. -- Joey Hess Thu, 07 May 2015 12:08:34 -0400 diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index 51ba69a4..1cf921cf 100644 --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -6,7 +6,6 @@ module Propellor.Bootstrap ( ) where import Propellor -import Utility.SafeCommand import System.Posix.Files import Data.List diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 1298daf2..219fe026 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -18,7 +18,6 @@ import Propellor.Types.CmdLine import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Chroot as Chroot import qualified Propellor.Shim as Shim -import Utility.SafeCommand usage :: Handle -> IO () usage h = hPutStrLn h $ unlines diff --git a/src/Propellor/Git.hs b/src/Propellor/Git.hs index 34bc43e2..0b9b4b35 100644 --- a/src/Propellor/Git.hs +++ b/src/Propellor/Git.hs @@ -3,7 +3,6 @@ module Propellor.Git where import Propellor import Propellor.PrivData.Paths import Propellor.Gpg -import Utility.SafeCommand import Utility.FileMode getCurrentBranch :: IO String diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs index a7c7e690..fe81dcd8 100644 --- a/src/Propellor/Property/Apache.hs +++ b/src/Propellor/Property/Apache.hs @@ -4,7 +4,6 @@ import Propellor import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service -import Utility.SafeCommand type ConfigFile = [String] diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index e56cb6ed..ec2b6679 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -19,7 +19,6 @@ import Propellor.Property.Chroot.Util import qualified Propellor.Property.Debootstrap as Debootstrap import qualified Propellor.Property.Systemd.Core as Systemd import qualified Propellor.Shim as Shim -import Utility.SafeCommand import qualified Data.Map as M import Data.List.Utils diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs index 859302c8..23f1075b 100644 --- a/src/Propellor/Property/Cmd.hs +++ b/src/Propellor/Property/Cmd.hs @@ -1,11 +1,20 @@ {-# LANGUAGE PackageImports #-} module Propellor.Property.Cmd ( + -- * Properties for running commands and scripts cmdProperty, cmdProperty', cmdPropertyEnv, + Script, scriptProperty, userScriptProperty, + -- * Lower-level interface for running commands + CommandParam(..), + boolSystem, + boolSystemEnv, + safeSystem, + safeSystemEnv, + shellEscape ) where import Control.Applicative @@ -40,15 +49,18 @@ cmdPropertyEnv cmd params env = property desc $ liftIO $ do where desc = unwords $ cmd : params --- | A property that can be satisfied by running a series of shell commands. -scriptProperty :: [String] -> Property NoInfo +-- | A series of shell commands. (Without a leading hashbang.) +type Script = [String] + +-- | A property that can be satisfied by running a script. +scriptProperty :: Script -> Property NoInfo scriptProperty script = cmdProperty "sh" ["-c", shellcmd] where shellcmd = intercalate " ; " ("set -e" : script) --- | A property that can satisfied by running a series of shell commands, +-- | A property that can satisfied by running a script -- as user (cd'd to their home directory). -userScriptProperty :: User -> [String] -> Property NoInfo +userScriptProperty :: User -> Script -> Property NoInfo userScriptProperty (User user) script = cmdProperty "su" ["--shell", "/bin/sh", "-c", shellcmd, user] where shellcmd = intercalate " ; " ("set -e" : "cd" : script) diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs index d2feaf3c..e9bb93ac 100644 --- a/src/Propellor/Property/Cron.hs +++ b/src/Propellor/Property/Cron.hs @@ -4,7 +4,6 @@ import Propellor import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import Propellor.Bootstrap -import Utility.SafeCommand import Utility.FileMode import Data.Char diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index 5d6a8bed..f29ae56b 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -15,7 +15,6 @@ import qualified Propellor.Property.Apt as Apt import Propellor.Property.Chroot.Util import Propellor.Property.Mount import Utility.Path -import Utility.SafeCommand import Utility.FileMode import Data.List diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 3b8751f3..fd7e37b2 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -48,7 +48,6 @@ import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Cmd as Cmd import qualified Propellor.Shim as Shim -import Utility.SafeCommand import Utility.Path import Utility.ThreadScheduler diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs index 66292c8b..ab57b122 100644 --- a/src/Propellor/Property/Firewall.hs +++ b/src/Propellor/Property/Firewall.hs @@ -18,7 +18,6 @@ import Data.Char import Data.List import Propellor -import Utility.SafeCommand import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Network as Network diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs index 0fc22616..48871b40 100644 --- a/src/Propellor/Property/Git.hs +++ b/src/Propellor/Property/Git.hs @@ -4,7 +4,6 @@ import Propellor import Propellor.Property.File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service -import Utility.SafeCommand import Data.List diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs index f4d10302..a081b1e7 100644 --- a/src/Propellor/Property/Mount.hs +++ b/src/Propellor/Property/Mount.hs @@ -1,7 +1,6 @@ module Propellor.Property.Mount where import Propellor -import Utility.SafeCommand type FsType = String type Source = String diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs index 11fa6c82..5364456a 100644 --- a/src/Propellor/Property/OS.hs +++ b/src/Propellor/Property/OS.hs @@ -16,7 +16,6 @@ import qualified Propellor.Property.File as File import qualified Propellor.Property.Reboot as Reboot import Propellor.Property.Mount import Propellor.Property.Chroot.Util (stdPATH) -import Utility.SafeCommand import System.Posix.Files (rename, fileExist) import Control.Exception (throw) diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs index da27e263..94b023f3 100644 --- a/src/Propellor/Property/Obnam.hs +++ b/src/Propellor/Property/Obnam.hs @@ -4,7 +4,6 @@ import Propellor import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Cron as Cron import qualified Propellor.Property.Gpg as Gpg -import Utility.SafeCommand import Data.List diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs index 750968ff..d45969a8 100644 --- a/src/Propellor/Property/Reboot.hs +++ b/src/Propellor/Property/Reboot.hs @@ -1,7 +1,6 @@ module Propellor.Property.Reboot where import Propellor -import Utility.SafeCommand now :: Property NoInfo now = cmdProperty "reboot" [] diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs index 8da502f7..9cc010e8 100644 --- a/src/Propellor/Property/Service.hs +++ b/src/Propellor/Property/Service.hs @@ -1,7 +1,6 @@ module Propellor.Property.Service where import Propellor -import Utility.SafeCommand type ServiceName = String diff --git a/src/Propellor/Property/SiteSpecific/GitHome.hs b/src/Propellor/Property/SiteSpecific/GitHome.hs index d6dce7c0..40f2ecd8 100644 --- a/src/Propellor/Property/SiteSpecific/GitHome.hs +++ b/src/Propellor/Property/SiteSpecific/GitHome.hs @@ -3,7 +3,6 @@ module Propellor.Property.SiteSpecific.GitHome where import Propellor import qualified Propellor.Property.Apt as Apt import Propellor.Property.User -import Utility.SafeCommand -- | Clones Joey Hess's git home directory, and runs its fixups script. installedFor :: User -> Property NoInfo diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs index 89b8b46d..f9a0e0c9 100644 --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -15,7 +15,6 @@ import qualified Propellor.Property.User as User import qualified Propellor.Property.Obnam as Obnam import qualified Propellor.Property.Apache as Apache import qualified Propellor.Property.Postfix as Postfix -import Utility.SafeCommand import Utility.FileMode import Data.List diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index 37e65728..785f2787 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -24,7 +24,6 @@ import Propellor import qualified Propellor.Property.File as File import qualified Propellor.Property.Service as Service import Propellor.Property.User -import Utility.SafeCommand import Utility.FileMode import System.PosixCompat diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs index 07cf81ee..78a99963 100644 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -25,7 +25,6 @@ import qualified Propellor.Property.Chroot as Chroot import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.File as File import Propellor.Property.Systemd.Core -import Utility.SafeCommand import Utility.FileMode import Data.List diff --git a/src/Propellor/Shim.hs b/src/Propellor/Shim.hs index 5fc1ea05..ecf9f36a 100644 --- a/src/Propellor/Shim.hs +++ b/src/Propellor/Shim.hs @@ -8,7 +8,6 @@ module Propellor.Shim (setup, cleanEnv, file) where import Propellor import Utility.LinuxMkLibs -import Utility.SafeCommand import Utility.FileMode import Utility.FileSystemEncoding diff --git a/src/Propellor/Ssh.hs b/src/Propellor/Ssh.hs index 97c3eb6d..ac9295d1 100644 --- a/src/Propellor/Ssh.hs +++ b/src/Propellor/Ssh.hs @@ -1,7 +1,6 @@ module Propellor.Ssh where import Propellor -import Utility.SafeCommand import Utility.UserInfo import System.PosixCompat diff --git a/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs index 0704e69f..82e35049 100644 --- a/src/Utility/SafeCommand.hs +++ b/src/Utility/SafeCommand.hs @@ -17,16 +17,15 @@ import Data.Char import Control.Applicative import Prelude -{- A type for parameters passed to a shell command. A command can - - be passed either some Params (multiple parameters can be included, - - whitespace-separated, or a single Param (for when parameters contain - - whitespace), or a File. - -} -data CommandParam = Params String | Param String | File FilePath +-- | Parameters that can be passed to a shell command. +data CommandParam + = Params String -- ^ Contains multiple parameters, separated by whitespace + | Param String -- ^ A single parameter + | File FilePath -- ^ The name of a file deriving (Eq, Show, Ord) -{- Used to pass a list of CommandParams to a function that runs - - a command and expects Strings. -} +-- | Used to pass a list of CommandParams to a function that runs +-- a command and expects Strings. -} toCommand :: [CommandParam] -> [String] toCommand = concatMap unwrap where @@ -43,9 +42,10 @@ toCommand = concatMap unwrap -- path separator on Windows. pathseps = pathSeparator:"./" -{- Run a system command, and returns True or False - - if it succeeded or failed. - -} +-- | Run a system command, and returns True or False if it succeeded or failed. +-- +-- This and other command running functions in this module log the commands +-- run at debug level, using System.Log.Logger. boolSystem :: FilePath -> [CommandParam] -> IO Bool boolSystem command params = boolSystem' command params id @@ -59,7 +59,7 @@ boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bo boolSystemEnv command params environ = boolSystem' command params $ \p -> p { env = environ } -{- Runs a system command, returning the exit status. -} +-- | Runs a system command, returning the exit status. safeSystem :: FilePath -> [CommandParam] -> IO ExitCode safeSystem command params = safeSystem' command params id @@ -74,23 +74,22 @@ safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Ex safeSystemEnv command params environ = safeSystem' command params $ \p -> p { env = environ } -{- Wraps a shell command line inside sh -c, allowing it to be run in a - - login shell that may not support POSIX shell, eg csh. -} +-- | Wraps a shell command line inside sh -c, allowing it to be run in a +-- login shell that may not support POSIX shell, eg csh. shellWrap :: String -> String shellWrap cmdline = "sh -c " ++ shellEscape cmdline -{- Escapes a filename or other parameter to be safely able to be exposed to - - the shell. - - - - This method works for POSIX shells, as well as other shells like csh. - -} +-- | Escapes a filename or other parameter to be safely able to be exposed to +-- the shell. +-- +-- This method works for POSIX shells, as well as other shells like csh. shellEscape :: String -> String shellEscape f = "'" ++ escaped ++ "'" where -- replace ' with '"'"' escaped = join "'\"'\"'" $ split "'" f -{- Unescapes a set of shellEscaped words or filenames. -} +-- | Unescapes a set of shellEscaped words or filenames. shellUnEscape :: String -> [String] shellUnEscape [] = [] shellUnEscape s = word : shellUnEscape rest @@ -107,19 +106,19 @@ shellUnEscape s = word : shellUnEscape rest | c == q = findword w cs | otherwise = inquote q (w++[c]) cs -{- For quickcheck. -} +-- | For quickcheck. prop_idempotent_shellEscape :: String -> Bool prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s prop_idempotent_shellEscape_multiword :: [String] -> Bool prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s -{- Segments a list of filenames into groups that are all below the maximum - - command-line length limit. -} +-- | Segments a list of filenames into groups that are all below the maximum +-- command-line length limit. segmentXargsOrdered :: [FilePath] -> [[FilePath]] segmentXargsOrdered = reverse . map reverse . segmentXargsUnordered -{- Not preserving data is a little faster, and streams better when - - there are a great many filesnames. -} +-- | Not preserving order is a little faster, and streams better when +-- there are a great many filenames. segmentXargsUnordered :: [FilePath] -> [[FilePath]] segmentXargsUnordered l = go l [] 0 [] where -- cgit v1.2.3 From e11c68cf1e515746e3bd0256a949e182ae735f99 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 1 Jun 2015 23:57:33 -0400 Subject: Docker: volume and publish accept Bound FilePath and Bound Port, respectively. They also continue to accept Strings, for backwards compatability. --- debian/changelog | 3 +++ src/Propellor/Property/Docker.hs | 36 +++++++++++++++++++++++++++++------- 2 files changed, 32 insertions(+), 7 deletions(-) (limited to 'src/Propellor/Property/Docker.hs') diff --git a/debian/changelog b/debian/changelog index c262eadf..f4459a2c 100644 --- a/debian/changelog +++ b/debian/changelog @@ -21,6 +21,9 @@ propellor (2.5.0) UNRELEASED; urgency=medium * Firewall: Port was changed to a newtype, and the Port and PortRange constructors of Rules were changed to DPort and DportRange, respectively. (API change) + * Docker: volume and publish accept Bound FilePath and Bound Port, + respectively. They also continue to accept Strings, for backwards + compatability. -- Joey Hess Thu, 07 May 2015 12:08:34 -0400 diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index fd7e37b2..1dcc3522 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -23,9 +23,11 @@ module Propellor.Property.Docker ( -- * Container configuration dns, hostname, + Publishable, publish, expose, user, + Mountable, volume, volumes_from, workdir, @@ -43,6 +45,7 @@ module Propellor.Property.Docker ( import Propellor hiding (init) import Propellor.Types.Docker +import Propellor.Types.Container import Propellor.Types.CmdLine import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt @@ -254,10 +257,19 @@ hostname = runProp "hostname" name :: String -> Property HasInfo name = runProp "name" +class Publishable p where + toPublish :: p -> String + +instance Publishable (Bound Port) where + toPublish p = show (hostSide p) ++ ":" ++ show (containerSide p) + +-- | string format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort +instance Publishable String where + toPublish = id + -- | Publish a container's port to the host --- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort) -publish :: String -> Property HasInfo -publish = runProp "publish" +publish :: Publishable p => p -> Property HasInfo +publish = runProp "publish" . toPublish -- | Expose a container's port without publishing it. expose :: String -> Property HasInfo @@ -267,11 +279,21 @@ expose = runProp "expose" user :: String -> Property HasInfo user = runProp "user" --- | Mount a volume --- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro] +class Mountable p where + toMount :: p -> String + +instance Mountable (Bound FilePath) where + toMount p = hostSide p ++ ":" ++ containerSide p + +-- | string format: [host-dir]:[container-dir]:[rw|ro] +-- -- With just a directory, creates a volume in the container. -volume :: String -> Property HasInfo -volume = runProp "volume" +instance Mountable String where + toMount = id + +-- | Mount a volume +volume :: Mountable v => v -> Property HasInfo +volume = runProp "volume" . toMount -- | Mount a volume from the specified container into the current -- container. -- cgit v1.2.3 From e1f2d4a8f1bf6f47ec7d091d2dbeb79a0d3ece02 Mon Sep 17 00:00:00 2001 From: Antoine Eiche Date: Wed, 3 Jun 2015 17:50:12 +0200 Subject: Add Docker environment property which allows to specify environment variables to containers. --- src/Propellor/Property/Docker.hs | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'src/Propellor/Property/Docker.hs') diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 1dcc3522..d3e60fc2 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -34,6 +34,7 @@ module Propellor.Property.Docker ( memory, cpuShares, link, + environment, ContainerAlias, restartAlways, restartOnFailure, @@ -348,6 +349,11 @@ restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n) restartNever :: Property HasInfo restartNever = runProp "restart" "no" +-- | Set environment variable with a tuple composed by the environment +-- variable name and its value. +environment :: (String, String) -> Property HasInfo +environment (k, v) = runProp "env" $ k ++ "=" ++ v + -- | A container is identified by its name, and the host -- on which it's deployed. data ContainerId = ContainerId -- cgit v1.2.3 From 46241b3a89e8fd612ca3af6a3dc6495df01dbfe6 Mon Sep 17 00:00:00 2001 From: Antoine Eiche Date: Mon, 15 Jun 2015 11:31:25 +0200 Subject: Replace String type synonym Docker.Image by a data type which allows to specify an image name and an optional tag. This also introduces the class ImageIdentifier which is internally used by some Docker methods. --- config-simple.hs | 2 +- src/Propellor/Property/Docker.hs | 79 ++++++++++++++++++++++++++++++++-------- 2 files changed, 64 insertions(+), 17 deletions(-) (limited to 'src/Propellor/Property/Docker.hs') diff --git a/config-simple.hs b/config-simple.hs index 4f0fde8c..576ecc73 100644 --- a/config-simple.hs +++ b/config-simple.hs @@ -41,7 +41,7 @@ hosts = -- A generic webserver in a Docker container. webserverContainer :: Docker.Container -webserverContainer = Docker.container "webserver" "debian" +webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") & os (System (Debian (Stable "jessie")) "amd64") & Apt.stdSourcesList & Docker.publish "80:80" diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index d3e60fc2..05f25c31 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -16,7 +16,8 @@ module Propellor.Property.Docker ( memoryLimited, garbageCollected, tweaked, - Image, + Image(..), + latestImage, ContainerName, Container, HasImage(..), @@ -155,8 +156,8 @@ docked ctr@(Container _ h) = imageBuilt :: HasImage c => FilePath -> c -> Property NoInfo imageBuilt directory ctr = describe built msg where - msg = "docker image " ++ image ++ " built from " ++ directory - built = Cmd.cmdProperty' dockercmd ["build", "--tag", image, "./"] workDir + msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory + built = Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir workDir p = p { cwd = Just directory } image = getImageName ctr @@ -164,8 +165,8 @@ imageBuilt directory ctr = describe built msg imagePulled :: HasImage c => c -> Property NoInfo imagePulled ctr = describe pulled msg where - msg = "docker image " ++ image ++ " pulled" - pulled = Cmd.cmdProperty dockercmd ["pull", image] + msg = "docker image " ++ (imageIdentifier image) ++ " pulled" + pulled = Cmd.cmdProperty dockercmd ["pull", imageIdentifier image] image = getImageName ctr propigateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo @@ -243,8 +244,52 @@ data ContainerInfo = ContainerInfo Image [RunParam] -- | Parameters to pass to `docker run` when creating a container. type RunParam = String --- | A docker image, that can be used to run a container. -type Image = String +-- | ImageID is an image identifier to perform action on images. An +-- ImageID can be the name of an container image, a UID, etc. +-- +-- It just encapsulates a String to avoid the definition of a String +-- instance of ImageIdentifier. +newtype ImageID = ImageID String + +-- | Used to perform Docker action on an image. +-- +-- Minimal complete definition: `imageIdentifier` +class ImageIdentifier i where + -- | For internal purposes only. + toImageID :: i -> ImageID + toImageID = ImageID . imageIdentifier + -- | A string that Docker can use as an image identifier. + imageIdentifier :: i -> String + +instance ImageIdentifier ImageID where + imageIdentifier (ImageID i) = i + toImageID = id + +-- | A docker image, that can be used to run a container. The user has +-- to specify a name and can provide an optional tag. +-- See +-- for more information. +data Image = Image + { repository :: String + , tag :: Maybe String + } + deriving (Eq, Read, Show) + +-- | Defines a Docker image without any tag. This is considered by +-- Docker as the latest image of the provided repository. +latestImage :: String -> Image +latestImage repo = Image repo Nothing + +instance ImageIdentifier Image where + -- | The format of the imageIdentifier of an `Image` is: + -- repository | repository:tag + imageIdentifier i = repository i ++ (maybe "" ((++) ":") $ tag i) + +-- | The UID of an image. This UID is generated by Docker. +newtype ImageUID = ImageUID String + +instance ImageIdentifier ImageUID where + imageIdentifier (ImageUID uid) = uid -- | Set custom dns server for container. dns :: String -> Property HasInfo @@ -424,7 +469,9 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope return FailedChange restartcontainer = do - oldimage <- liftIO $ fromMaybe image <$> commitContainer cid + oldimage <- liftIO $ + fromMaybe (toImageID image) . fmap toImageID <$> + commitContainer cid void $ liftIO $ removeContainer cid go oldimage @@ -561,20 +608,20 @@ removeContainer :: ContainerId -> IO Bool removeContainer cid = catchBoolIO $ snd <$> processTranscript dockercmd ["rm", fromContainerId cid ] Nothing -removeImage :: Image -> IO Bool +removeImage :: ImageIdentifier i => i -> IO Bool removeImage image = catchBoolIO $ - snd <$> processTranscript dockercmd ["rmi", image ] Nothing + snd <$> processTranscript dockercmd ["rmi", imageIdentifier image] Nothing -runContainer :: Image -> [RunParam] -> [String] -> IO Bool +runContainer :: ImageIdentifier i => i -> [RunParam] -> [String] -> IO Bool runContainer image ps cmd = boolSystem dockercmd $ map Param $ - "run" : (ps ++ image : cmd) + "run" : (ps ++ (imageIdentifier image) : cmd) inContainerProcess :: ContainerId -> [String] -> [String] -> CreateProcess inContainerProcess cid ps cmd = proc dockercmd ("exec" : ps ++ [fromContainerId cid] ++ cmd) -commitContainer :: ContainerId -> IO (Maybe Image) +commitContainer :: ContainerId -> IO (Maybe ImageUID) commitContainer cid = catchMaybeIO $ - takeWhile (/= '\n') + ImageUID . takeWhile (/= '\n') <$> readProcess dockercmd ["commit", fromContainerId cid] data ContainerFilter = RunningContainers | AllContainers @@ -592,8 +639,8 @@ listContainers status = | otherwise = baseps baseps = ["ps", "--no-trunc"] -listImages :: IO [Image] -listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"] +listImages :: IO [ImageUID] +listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"] runProp :: String -> RunParam -> Property HasInfo runProp field val = pureInfoProperty (param) $ dockerInfo $ -- cgit v1.2.3