summaryrefslogtreecommitdiff
path: root/src/Propellor
diff options
context:
space:
mode:
authorAntoine Eiche2015-06-15 11:31:25 +0200
committerJoey Hess2015-06-16 14:48:59 -0400
commit46241b3a89e8fd612ca3af6a3dc6495df01dbfe6 (patch)
treea03641141405fed5f89f0ef1a88e9ff02f126445 /src/Propellor
parentb5de5703a49e59db010518b89effdeba3b91a664 (diff)
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.
Diffstat (limited to 'src/Propellor')
-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 $