Merge branch 'master' of https://github.com/denibertovic/docker-hs

src/Docker/Client/Api.hs

@@ -18,6 +18,7 @@ module Docker.Client.Api (
     , getContainerLogsStream
     -- * Images
     , listImages
+    , deleteImage
     , buildImageFromDockerfile
     , pullImage
     -- * Network
@@ -93,6 +94,12 @@ listContainers opts = requestHelper GET (ListContainersEndpoint opts) >>= parseR
 listImages :: forall m. (MonadIO m, MonadMask m) => ListOpts -> DockerT m (Either DockerError [Image])
 listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse
 
+-- | Deletes an image with the given 'ImageID'.
+-- See "ImageDeleteOpts" for options and use 'defaultImageDeleteOpts' for sane
+-- defaults.
+deleteImage :: forall m. (MonadIO m, MonadMask m) => ImageDeleteOpts -> ImageID -> DockerT m (Either DockerError ())
+deleteImage dopts iid = requestUnit DELETE $ DeleteImageEndpoint dopts iid
+
 -- | Creates a docker container but does __not__ start it. See
 -- 'CreateOpts' for a list of options and you can use 'defaultCreateOpts'
 -- for some sane defaults.
@@ -138,9 +145,9 @@ unpauseContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT
 unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid
 
 -- | Deletes a container with the given 'ContainerID'.
--- See "DeleteOpts" for options and use 'defaultDeleteOpts' for sane
+-- See "ContainerDeleteOpts" for options and use 'defaultContainerDeleteOpts' for sane
 -- defaults.
-deleteContainer :: forall m. (MonadIO m, MonadMask m) => DeleteOpts -> ContainerID -> DockerT m (Either DockerError ())
+deleteContainer :: forall m. (MonadIO m, MonadMask m) => ContainerDeleteOpts -> ContainerID -> DockerT m (Either DockerError ())
 deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid
 
 -- | Gets 'ContainerDetails' for a given 'ContainerID'.

src/Docker/Client/Http.hs

@@ -273,6 +273,11 @@ statusCodeToError (CreateImageEndpoint _ _ _) st =
         Nothing
     else
         Just $ DockerInvalidStatusCode st
+statusCodeToError (DeleteImageEndpoint _ _) st =
+    if st == status200 then
+        Nothing
+    else
+        Just $ DockerInvalidStatusCode st
 statusCodeToError (CreateNetworkEndpoint _) st =
     if st == status201 then
         Nothing
@@ -283,4 +288,3 @@ statusCodeToError (RemoveNetworkEndpoint _) st =
         Nothing
     else
         Just $ DockerInvalidStatusCode st
-

src/Docker/Client/Internal.hs

@@ -57,7 +57,7 @@ getEndpoint v (UnpauseContainerEndpoint cid) = encodeURL [v, "containers", fromC
 getEndpoint v (ContainerLogsEndpoint (LogOpts stdout stderr _ _ _) follow cid) =
             encodeURLWithQuery    [v, "containers", fromContainerID cid, "logs"] query
         where query = [("stdout", Just (encodeQ $ show stdout)), ("stderr", Just (encodeQ $ show stderr)), ("follow", Just (encodeQ $ show follow))]
-getEndpoint v (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =
+getEndpoint v (DeleteContainerEndpoint (ContainerDeleteOpts removeVolumes force) cid) =
             encodeURLWithQuery [v, "containers", fromContainerID cid] query
         where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))]
 getEndpoint v (InspectContainerEndpoint cid) =
@@ -75,6 +75,7 @@ getEndpoint v (CreateImageEndpoint name tag _) = encodeURLWithQuery [v, "images"
         where query = [("fromImage", Just n), ("tag", Just t)]
               n = encodeQ $ T.unpack name
               t = encodeQ $ T.unpack tag
+getEndpoint v (DeleteImageEndpoint _ cid) = encodeURL [v, "images", fromImageID cid]
 getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"]
 getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid]
 
@@ -96,6 +97,8 @@ getEndpointRequestBody (InspectContainerEndpoint _) = Nothing
 
 getEndpointRequestBody (BuildImageEndpoint _ fp) = Just $ requestBodySourceChunked $ CB.sourceFile fp
 getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing
+getEndpointRequestBody (DeleteImageEndpoint _ _) = Nothing
+
 getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)
 getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing
 

src/Docker/Client/Types.hs

@@ -40,8 +40,10 @@ module Docker.Client.Types (
     , DetachKeys(..)
     , StartOpts(..)
     , defaultStartOpts
-    , DeleteOpts(..)
-    , defaultDeleteOpts
+    , ContainerDeleteOpts(..)
+    , defaultContainerDeleteOpts
+    , ImageDeleteOpts(..)
+    , defaultImageDeleteOpts
     , Timestamp
     , TailLogOpt(..)
     , LogOpts(..)
@@ -130,10 +132,11 @@ data Endpoint =
       | UnpauseContainerEndpoint ContainerID
       | ContainerLogsEndpoint LogOpts Bool ContainerID -- ^ Second argument (Bool) is whether to follow which is currently hardcoded to False.
       -- See note in 'Docker.Client.Api.getContainerLogs' for explanation why.
-      | DeleteContainerEndpoint DeleteOpts ContainerID
+      | DeleteContainerEndpoint ContainerDeleteOpts ContainerID
       | InspectContainerEndpoint ContainerID
       | BuildImageEndpoint BuildOpts FilePath
       | CreateImageEndpoint T.Text Tag (Maybe T.Text) -- ^ Either pull an image from docker hub or imports an image from a tarball (or URL)
+      | DeleteImageEndpoint ImageDeleteOpts ImageID
       | CreateNetworkEndpoint CreateNetworkOpts
       | RemoveNetworkEndpoint NetworkID
     deriving (Eq, Show)
@@ -759,7 +762,7 @@ defaultStartOpts :: StartOpts
 defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }
 
 -- | Options for deleting a container.
-data DeleteOpts = DeleteOpts {
+data ContainerDeleteOpts = ContainerDeleteOpts {
                   deleteVolumes :: Bool -- ^ Automatically cleanup volumes that the container created as well.
                 , force         :: Bool -- ^ If the container is still running force deletion anyway.
                 } deriving (Eq, Show)
@@ -789,8 +792,15 @@ defaultBuildOpts nameTag = BuildOpts { buildImageName = nameTag
 -- | Default options for deleting a container. Most of the time we DON'T
 -- want to delete the container's volumes or force delete it if it's
 -- running.
-defaultDeleteOpts :: DeleteOpts
-defaultDeleteOpts = DeleteOpts { deleteVolumes = False, force = False }
+defaultContainerDeleteOpts :: ContainerDeleteOpts
+defaultContainerDeleteOpts = ContainerDeleteOpts { deleteVolumes = False, force = False }
+
+-- | Image delete opts
+data ImageDeleteOpts = ImageDeleteOpts deriving (Eq, Show)
+
+-- | Sane image deletion defaults
+defaultImageDeleteOpts :: ImageDeleteOpts
+defaultImageDeleteOpts = ImageDeleteOpts
 
 -- | Timestamp alias.
 type Timestamp = Integer

tests/tests.hs

@@ -24,7 +24,7 @@ import qualified Data.ByteString.Lazy      as BL
 import qualified Data.HashMap.Strict       as HM
 import           Data.Int                  (Int)
 import qualified Data.Map                  as M
-import           Data.Maybe                (fromJust, isJust)
+import           Data.Maybe                (fromJust, isJust, isNothing, listToMaybe)
 import           Data.Monoid
 import           Data.Text                 (Text, unpack)
 import qualified Data.Vector               as V
@@ -40,6 +40,7 @@ import           Docker.Client
 
 -- opts = defaultClientOpts
 testImageName = "docker-hs/test"
+imageToDeleteFullName = "hello-world:latest"
 
 toStrict1 = B.concat . BL.toChunks
 
@@ -73,13 +74,27 @@ testFindImage =
   where
     imageFullName = testImageName <> ":latest"
 
+testDeleteImage :: IO ()
+testDeleteImage = runDocker $ do
+  (Just img) <- findTestImage
+  result <- deleteImage defaultImageDeleteOpts (imageId img)
+  lift $ assert $ isRight result
+  maybeTestImageAfter <- findTestImage
+  lift $ assert $ isNothing maybeTestImageAfter
+  where
+    findTestImage =
+      do
+        images <- listImages defaultListOpts >>= fromRight
+        return $ listToMaybe
+               $ filter (elem imageToDeleteFullName . imageRepoTags) images
+
 testListContainers :: IO ()
 testListContainers =
   runDocker $
   do containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing
      c <- fromRight containerId
      res <- listContainers $ ListOpts { all=True }
-     deleteContainer (DeleteOpts True True) c
+     deleteContainer (ContainerDeleteOpts True True) c
      lift $ assert $ isRight res
 
 testBuildFromDockerfile :: IO ()
@@ -110,7 +125,7 @@ testRunAndReadLogHelper networkingConfig =
      lift $ assertBool ("starting the container, unexpected status: " ++ show status1) $ isRightUnit status1
      logs <- getContainerLogs defaultLogOpts c >>= fromRight
      lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
-     status3 <- deleteContainer (DeleteOpts True True) c
+     status3 <- deleteContainer (ContainerDeleteOpts True True) c
      lift $ assertBool ("deleting container, unexpected status: " ++ show status3) $ isRightUnit status3
      mapM_ removeNetwork createdNetworks
   where
@@ -228,6 +243,7 @@ integrationTests =
     [ testCase "Get docker version" testDockerVersion
     , testCase "Build image from Dockerfile" testBuildFromDockerfile
     , testCase "Find image by name" testFindImage
+    , testCase "Delete image" testDeleteImage
     , testCase "List containers" testListContainers
     , testCase "Run a dummy container and read its log" testRunAndReadLog
     , testCase "Run a dummy container with networking and read its log" testRunAndReadLogWithNetworking
@@ -249,7 +265,11 @@ jsonTests =
     ]
 
 setup :: IO ()
-setup = system ("docker build -t " ++ unpack testImageName ++ " tests") >> return ()
+setup =
+  mapM_ system
+        [ "docker pull " ++ unpack imageToDeleteFullName
+        , "docker build -t " ++ unpack testImageName ++ " tests"
+        ]
 
 isLeft = not . isRight