d44ca8b · docker-hs · git.iko.soy

git.iko.soy/docker-hs

on master help sign in

Image deletion implementation

d44ca8bIvan Kasatenko8 years ago

src/Docker/Client/Api.hs+9−2

compare with master

unifiedsplit

@@ -18,6 +18,7 @@ module Docker.Client.Api (

18 , getContainerLogsStream

19 -- * Images

20 , listImages

21+ , deleteImage

21 , buildImageFromDockerfile

22 , buildImageFromDockerfile

22 , pullImage

23 , pullImage

23 -- * Network

24 -- * Network

@@ -93,6 +94,12 @@ listContainers opts = requestHelper GET (ListContainersEndpoint opts) >>= parseR

93listImages :: forall m. (MonadIO m, MonadMask m) => ListOpts -> DockerT m (Either DockerError [Image])

94listImages :: forall m. (MonadIO m, MonadMask m) => ListOpts -> DockerT m (Either DockerError [Image])

94listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse

95listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse

97+-- | Deletes an image with the given 'ImageID'.

98+-- See "ImageDeleteOpts" for options and use 'defaultImageDeleteOpts' for sane

99+-- defaults.

100+deleteImage :: forall m. (MonadIO m, MonadMask m) => ImageDeleteOpts -> ImageID -> DockerT m (Either DockerError ())

101+deleteImage dopts iid = requestUnit DELETE $ DeleteImageEndpoint dopts iid

102+

96-- | Creates a docker container but does __not__ start it. See

103-- | Creates a docker container but does __not__ start it. See

97-- 'CreateOpts' for a list of options and you can use 'defaultCreateOpts'

104-- 'CreateOpts' for a list of options and you can use 'defaultCreateOpts'

98-- for some sane defaults.

105-- for some sane defaults.

@@ -138,9 +145,9 @@ unpauseContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT

138unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid

145unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid

139

146

140-- | Deletes a container with the given 'ContainerID'.

147-- | Deletes a container with the given 'ContainerID'.

141−-- See "DeleteOpts" for options and use 'defaultDeleteOpts' for sane

148+-- See "ContainerDeleteOpts" for options and use 'defaultContainerDeleteOpts' for sane

142-- defaults.

149-- defaults.

143−deleteContainer :: forall m. (MonadIO m, MonadMask m) => DeleteOpts -> ContainerID -> DockerT m (Either DockerError ())

150+deleteContainer :: forall m. (MonadIO m, MonadMask m) => ContainerDeleteOpts -> ContainerID -> DockerT m (Either DockerError ())

144deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid

151deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid

145

152

146-- | Gets 'ContainerDetails' for a given 'ContainerID'.

153-- | Gets 'ContainerDetails' for a given 'ContainerID'.

src/Docker/Client/Http.hs+5−1

@@ -273,6 +273,11 @@ statusCodeToError (CreateImageEndpoint _ _ _) st =

273 Nothing

274 else

275 Just $ DockerInvalidStatusCode st

276+statusCodeToError (DeleteImageEndpoint _ _) st =

277+ if st == status200 then

278+ Nothing

279+ else

280+ Just $ DockerInvalidStatusCode st

276statusCodeToError (CreateNetworkEndpoint _) st =

281statusCodeToError (CreateNetworkEndpoint _) st =

277 if st == status201 then

282 if st == status201 then

278 Nothing

283 Nothing

@@ -283,4 +288,3 @@ statusCodeToError (RemoveNetworkEndpoint _) st =

283 Nothing

288 Nothing

284 else

289 else

285 Just $ DockerInvalidStatusCode st

290 Just $ DockerInvalidStatusCode st

286−

src/Docker/Client/Internal.hs+4−1

@@ -57,7 +57,7 @@ getEndpoint v (UnpauseContainerEndpoint cid) = encodeURL [v, "containers", fromC

57getEndpoint v (ContainerLogsEndpoint (LogOpts stdout stderr _ _ _) follow cid) =

58 encodeURLWithQuery [v, "containers", fromContainerID cid, "logs"] query

59 where query = [("stdout", Just (encodeQ $ show stdout)), ("stderr", Just (encodeQ $ show stderr)), ("follow", Just (encodeQ $ show follow))]

60−getEndpoint v (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =

60+getEndpoint v (DeleteContainerEndpoint (ContainerDeleteOpts removeVolumes force) cid) =

61 encodeURLWithQuery [v, "containers", fromContainerID cid] query

62 where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))]

63getEndpoint v (InspectContainerEndpoint cid) =

@@ -75,6 +75,7 @@ getEndpoint v (CreateImageEndpoint name tag _) = encodeURLWithQuery [v, "images"

75 where query = [("fromImage", Just n), ("tag", Just t)]

76 n = encodeQ $ T.unpack name

77 t = encodeQ $ T.unpack tag

78+getEndpoint v (DeleteImageEndpoint _ cid) = encodeURL [v, "images", fromImageID cid]

78getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"]

79getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"]

79getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid]

80getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid]

@@ -96,6 +97,8 @@ getEndpointRequestBody (InspectContainerEndpoint _) = Nothing

97getEndpointRequestBody (BuildImageEndpoint _ fp) = Just $ requestBodySourceChunked $ CB.sourceFile fp

98getEndpointRequestBody (BuildImageEndpoint _ fp) = Just $ requestBodySourceChunked $ CB.sourceFile fp

98getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing

99getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing

100+getEndpointRequestBody (DeleteImageEndpoint _ _) = Nothing

101+

99getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)

102getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)

100getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing

103getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing

101

104

src/Docker/Client/Types.hs+16−6

@@ -40,8 +40,10 @@ module Docker.Client.Types (

40 , DetachKeys(..)

41 , StartOpts(..)

42 , defaultStartOpts

43− , DeleteOpts(..)

43+ , ContainerDeleteOpts(..)

44− , defaultDeleteOpts

44+ , defaultContainerDeleteOpts

45+ , ImageDeleteOpts(..)

46+ , defaultImageDeleteOpts

45 , Timestamp

47 , Timestamp

46 , TailLogOpt(..)

48 , TailLogOpt(..)

47 , LogOpts(..)

49 , LogOpts(..)

@@ -130,10 +132,11 @@ data Endpoint =

130 | UnpauseContainerEndpoint ContainerID

132 | UnpauseContainerEndpoint ContainerID

131 | ContainerLogsEndpoint LogOpts Bool ContainerID -- ^ Second argument (Bool) is whether to follow which is currently hardcoded to False.

133 | ContainerLogsEndpoint LogOpts Bool ContainerID -- ^ Second argument (Bool) is whether to follow which is currently hardcoded to False.

132 -- See note in 'Docker.Client.Api.getContainerLogs' for explanation why.

134 -- See note in 'Docker.Client.Api.getContainerLogs' for explanation why.

133− | DeleteContainerEndpoint DeleteOpts ContainerID

135+ | DeleteContainerEndpoint ContainerDeleteOpts ContainerID

134 | InspectContainerEndpoint ContainerID

136 | InspectContainerEndpoint ContainerID

135 | BuildImageEndpoint BuildOpts FilePath

137 | BuildImageEndpoint BuildOpts FilePath

136 | CreateImageEndpoint T.Text Tag (Maybe T.Text) -- ^ Either pull an image from docker hub or imports an image from a tarball (or URL)

138 | CreateImageEndpoint T.Text Tag (Maybe T.Text) -- ^ Either pull an image from docker hub or imports an image from a tarball (or URL)

139+ | DeleteImageEndpoint ImageDeleteOpts ImageID

137 | CreateNetworkEndpoint CreateNetworkOpts

140 | CreateNetworkEndpoint CreateNetworkOpts

138 | RemoveNetworkEndpoint NetworkID

141 | RemoveNetworkEndpoint NetworkID

139 deriving (Eq, Show)

142 deriving (Eq, Show)

@@ -759,7 +762,7 @@ defaultStartOpts :: StartOpts

759defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }

762defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }

760

763

761-- | Options for deleting a container.

764-- | Options for deleting a container.

762−data DeleteOpts = DeleteOpts {

765+data ContainerDeleteOpts = ContainerDeleteOpts {

763 deleteVolumes :: Bool -- ^ Automatically cleanup volumes that the container created as well.

766 deleteVolumes :: Bool -- ^ Automatically cleanup volumes that the container created as well.

764 , force :: Bool -- ^ If the container is still running force deletion anyway.

767 , force :: Bool -- ^ If the container is still running force deletion anyway.

765 } deriving (Eq, Show)

768 } deriving (Eq, Show)

@@ -789,8 +792,15 @@ defaultBuildOpts nameTag = BuildOpts { buildImageName = nameTag

789-- | Default options for deleting a container. Most of the time we DON'T

792-- | Default options for deleting a container. Most of the time we DON'T

790-- want to delete the container's volumes or force delete it if it's

793-- want to delete the container's volumes or force delete it if it's

791-- running.

794-- running.

792−defaultDeleteOpts :: DeleteOpts

795+defaultContainerDeleteOpts :: ContainerDeleteOpts

793−defaultDeleteOpts = DeleteOpts { deleteVolumes = False, force = False }

796+defaultContainerDeleteOpts = ContainerDeleteOpts { deleteVolumes = False, force = False }

797+

798+-- | Image delete opts

799+data ImageDeleteOpts = ImageDeleteOpts deriving (Eq, Show)

800+

801+-- | Sane image deletion defaults

802+defaultImageDeleteOpts :: ImageDeleteOpts

803+defaultImageDeleteOpts = ImageDeleteOpts

794

804

795-- | Timestamp alias.

805-- | Timestamp alias.

796type Timestamp = Integer

806type Timestamp = Integer

tests/tests.hs+24−4

@@ -24,7 +24,7 @@ import qualified Data.ByteString.Lazy as BL

24import qualified Data.HashMap.Strict as HM

25import Data.Int (Int)

26import qualified Data.Map as M

27−import Data.Maybe (fromJust, isJust)

27+import Data.Maybe (fromJust, isJust, isNothing, listToMaybe)

28import Data.Monoid

29import Data.Text (Text, unpack)

30import qualified Data.Vector as V

@@ -40,6 +40,7 @@ import Docker.Client

41-- opts = defaultClientOpts

42testImageName = "docker-hs/test"

43+imageToDeleteFullName = "hello-world:latest"

44toStrict1 = B.concat . BL.toChunks

45toStrict1 = B.concat . BL.toChunks

@@ -73,13 +74,27 @@ testFindImage =

73 where

74 where

74 imageFullName = testImageName <> ":latest"

75 imageFullName = testImageName <> ":latest"

77+testDeleteImage :: IO ()

78+testDeleteImage = runDocker $ do

79+ (Just img) <- findTestImage

80+ result <- deleteImage defaultImageDeleteOpts (imageId img)

81+ lift $ assert $ isRight result

82+ maybeTestImageAfter <- findTestImage

83+ lift $ assert $ isNothing maybeTestImageAfter

84+ where

85+ findTestImage =

86+ do

87+ images <- listImages defaultListOpts >>= fromRight

88+ return $ listToMaybe

89+ $ filter (elem imageToDeleteFullName . imageRepoTags) images

90+

76testListContainers :: IO ()

91testListContainers :: IO ()

77testListContainers =

92testListContainers =

78 runDocker $

93 runDocker $

79 do containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing

94 do containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing

80 c <- fromRight containerId

95 c <- fromRight containerId

81 res <- listContainers $ ListOpts { all=True }

96 res <- listContainers $ ListOpts { all=True }

82− deleteContainer (DeleteOpts True True) c

97+ deleteContainer (ContainerDeleteOpts True True) c

83 lift $ assert $ isRight res

98 lift $ assert $ isRight res

85testBuildFromDockerfile :: IO ()

100testBuildFromDockerfile :: IO ()

@@ -110,7 +125,7 @@ testRunAndReadLogHelper networkingConfig =

110 lift $ assertBool ("starting the container, unexpected status: " ++ show status1) $ isRightUnit status1

125 lift $ assertBool ("starting the container, unexpected status: " ++ show status1) $ isRightUnit status1

111 logs <- getContainerLogs defaultLogOpts c >>= fromRight

126 logs <- getContainerLogs defaultLogOpts c >>= fromRight

112 lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)

127 lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)

113− status3 <- deleteContainer (DeleteOpts True True) c

128+ status3 <- deleteContainer (ContainerDeleteOpts True True) c

114 lift $ assertBool ("deleting container, unexpected status: " ++ show status3) $ isRightUnit status3

129 lift $ assertBool ("deleting container, unexpected status: " ++ show status3) $ isRightUnit status3

115 mapM_ removeNetwork createdNetworks

130 mapM_ removeNetwork createdNetworks

116 where

131 where

@@ -228,6 +243,7 @@ integrationTests =

228 [ testCase "Get docker version" testDockerVersion

243 [ testCase "Get docker version" testDockerVersion

229 , testCase "Build image from Dockerfile" testBuildFromDockerfile

244 , testCase "Build image from Dockerfile" testBuildFromDockerfile

230 , testCase "Find image by name" testFindImage

245 , testCase "Find image by name" testFindImage

246+ , testCase "Delete image" testDeleteImage

231 , testCase "List containers" testListContainers

247 , testCase "List containers" testListContainers

232 , testCase "Run a dummy container and read its log" testRunAndReadLog

248 , testCase "Run a dummy container and read its log" testRunAndReadLog

233 , testCase "Run a dummy container with networking and read its log" testRunAndReadLogWithNetworking

249 , testCase "Run a dummy container with networking and read its log" testRunAndReadLogWithNetworking

@@ -249,7 +265,11 @@ jsonTests =

249 ]

265 ]

250

266

251setup :: IO ()

267setup :: IO ()

268+setup =

269+ mapM_ system

270+ [ "docker pull " ++ unpack imageToDeleteFullName

252−setup = system ("docker build -t " ++ unpack testImageName ++ " tests") >> return ()

271+ , "docker build -t " ++ unpack testImageName ++ " tests"

272+ ]

253

273

254isLeft = not . isRight

274isLeft = not . isRight

255

275