mirror of
https://github.com/ilyakooo0/docker-hs.git
synced 2024-09-11 10:35:29 +03:00
Merge branch 'master' of https://github.com/denibertovic/docker-hs
This commit is contained in:
commit
46d78d6618
@ -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'.
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user