diff options
Diffstat (limited to 'src/Propellor/Property/Docker.hs')
| -rw-r--r-- | src/Propellor/Property/Docker.hs | 140 |
1 files changed, 106 insertions, 34 deletions
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index fdc312ce..05f25c31 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -16,22 +16,26 @@ module Propellor.Property.Docker ( memoryLimited, garbageCollected, tweaked, - Image, + Image(..), + latestImage, ContainerName, Container, HasImage(..), -- * Container configuration dns, hostname, + Publishable, publish, expose, user, + Mountable, volume, volumes_from, workdir, memory, cpuShares, link, + environment, ContainerAlias, restartAlways, restartOnFailure, @@ -43,12 +47,12 @@ 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 import qualified Propellor.Property.Cmd as Cmd import qualified Propellor.Shim as Shim -import Utility.SafeCommand import Utility.Path import Utility.ThreadScheduler @@ -152,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 @@ -161,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 @@ -240,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 <http://docs.docker.com/userguide/dockerimages/ Docker Image Documention> +-- 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 @@ -255,10 +303,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 @@ -268,11 +325,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. @@ -327,6 +394,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 @@ -397,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 @@ -426,16 +500,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. @@ -536,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 @@ -567,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 $ |