summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Docker.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property/Docker.hs')
-rw-r--r--src/Propellor/Property/Docker.hs79
1 files changed, 63 insertions, 16 deletions
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 <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
@@ -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 $