on master help sign in
.gitignore+1
since splitsnapshots
unifiedsplit
@@ -4,3 +4,4 @@
4*~
4*~
5.stack-work/
5.stack-work/
6dist-newstyle
6dist-newstyle
7+/cabal.project.local
.travis.yml+25−3
@@ -22,8 +22,30 @@ services:
22 - docker
22 - docker
23
23
24env:
24env:
25− - GHCVER=7.10 STACK_ARGS=""
25+ global:
26− - GHCVER=8.0 STACK_ARGS=""
26+ - RUN_INTEGRATION_TESTS=1
27+ - STACK_ARGS=""
28+
29+ matrix:
30+ - DOCKER_VERSION="1.12.3-0~trusty" GHCVER=7.10
31+ - DOCKER_VERSION="1.13.1-0~ubuntu-trusty" GHCVER=7.10
32+ - DOCKER_VERSION="17.05.0~ce-0~ubuntu-trusty" GHCVER=7.10
33+
34+ - DOCKER_VERSION="1.12.3-0~trusty" GHCVER=8.0
35+ - DOCKER_VERSION="1.13.1-0~ubuntu-trusty" GHCVER=8.0
36+ - DOCKER_VERSION="17.05.0~ce-0~ubuntu-trusty" GHCVER=8.0
37+
38+ - DOCKER_VERSION="1.12.3-0~trusty" GHCVER=8.0.2
39+ - DOCKER_VERSION="1.13.1-0~ubuntu-trusty" GHCVER=8.0.2
40+ - DOCKER_VERSION="17.05.0~ce-0~ubuntu-trusty" GHCVER=8.0.2
41+
42+ - DOCKER_VERSION="1.12.3-0~trusty" GHCVER=8.6.4
43+ - DOCKER_VERSION="1.13.1-0~ubuntu-trusty" GHCVER=8.6.4
44+ - DOCKER_VERSION="17.05.0~ce-0~ubuntu-trusty" GHCVER=8.6.4
45+
46+ - DOCKER_VERSION="1.12.3-0~trusty" GHCVER=8.8.2
47+ - DOCKER_VERSION="1.13.1-0~ubuntu-trusty" GHCVER=8.8.2
48+ - DOCKER_VERSION="17.05.0~ce-0~ubuntu-trusty" GHCVER=8.8.2
27
49
28addons:
50addons:
29 apt:
51 apt:
@@ -35,7 +57,7 @@ before_install:
35 - sudo sh -c 'echo "deb https://apt.dockerproject.org/repo ubuntu-trusty main" > /etc/apt/sources.list.d/docker.list'
57 - sudo sh -c 'echo "deb https://apt.dockerproject.org/repo ubuntu-trusty main" > /etc/apt/sources.list.d/docker.list'
36 - sudo apt-key adv --keyserver hkp://p80.pool.sks-keyservers.net:80 --recv-keys 58118E89F3A912897C070ADBF76221572C52609D
58 - sudo apt-key adv --keyserver hkp://p80.pool.sks-keyservers.net:80 --recv-keys 58118E89F3A912897C070ADBF76221572C52609D
37 - sudo apt-get update
59 - sudo apt-get update
38− - sudo apt-get -qqy -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confold" install docker-engine=1.12.3-0~trusty
60+ - sudo apt-get -qqy -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confold" install docker-engine=$DOCKER_VERSION
39
61
40install:
62install:
41 - mkdir -p "$HOME"/.local/bin
63 - mkdir -p "$HOME"/.local/bin
CHANGELOG.md+71
@@ -1,5 +1,76 @@
1# CHANGELOG
1# CHANGELOG
2
2
3+## 0.6.0.3 (2020-02-17)
4+
5+- Support for ghc 8.8.2.
6+- Bump dependency version.
7+- Use MonadFail for later versions.
8+
9+## 0.6.0.1 (2019-05-23)
10+
11+- Support ghc 8.6.4.
12+- Bump containers version.
13+
14+## 0.6.0.0 (2018-06-28)
15+
16+- Rename DeleteOpts to ContainerDeleteOpts.
17+- Implement image deletion.
18+- Bump aeson version.
19+- Implement network aliases.
20+- Implement creating/deleting networks.
21+
22+## 0.5.1.1 (2018-03-09)
23+
24+- Bump aeson version.
25+
26+## 0.5.1.0 (2018-02-23)
27+
28+- Support http-conduit-2.3.0.
29+- Bump http-types versions.
30+
31+## 0.5.0.1 (2018-01-26)
32+
33+- Bumps upper bound for http-types (properly this time).
34+
35+## 0.5.0.0 (2018-01-24)
36+
37+- Added (some) contribution and general docs
38+- Fix case when stopping non-existent container
39+- Added more integration tests
40+- Fixed error while parsing list container endpoint output
41+- Changed State/Status data type (related to the above fix)
42+- Added tests against different docker version to travis CIA
43+- Fixed EnvVar JSON encoding
44+- Fixed NetworkMode parsing
45+- Allow http-types 0.11
46+
47+## 0.4.1.1 (2017-10-16)
48+
49+- Small change to add env var for skipping integration tests.
50+ This is mostly to avoid running those on stackage.
51+
52+## 0.4.1.0 (2017-10-04)
53+
54+- Relaxed aeson, tls and time upper bounds
55+
56+
57+## 0.4.0.2 (2017-09-19)
58+
59+- Support LTS 9.4
60+
61+## 0.4.0.1 (2017-06-29)
62+
63+- fixes omKillDisable parsing from json
64+- adds Entrypoint data type and tests edge cases
65+- more tests
66+- small comsmetic changes
67+
68+## 0.4.0.0 (2017-03-20)
69+
70+- Adds streaming support via conduits (changes API a bit hence the major version release)
71+- Added support for streaming log output
72+- Added support for pulling images from the hub (and streaming the output)
73+
3## 0.3.0.1 (2016-09-07)
74## 0.3.0.1 (2016-09-07)
4
75
5- Small cosmetic changes and marking OVERLAPPING instance
76- Small cosmetic changes and marking OVERLAPPING instance
CONTRIBUTING.md+12−2
@@ -1,4 +1,14 @@
1−# TODO
1+# Contributing
2
2
3−Add basic guidelines here, things like style guide (using .configuration files from the repo) etc etc.
3+If you wish to contribute please see [any issue on GitHub tagged with "help
4+wanted"](https://github.com/denibertovic/docker-hs/issues?q=is%3Aopen+is%3Aissue+label%3A%22help+wanted%22).
5+Before starting to work, consider commenting on the issue you want to resolve or
6+open a new issue to discuss design decisions and implementation details. This is
7+so that no development cycles go to waste on implementing a feature that might
8+not get merged either because of implementation details or other reasons.
4
9
10+Make sure to submit your PR's against the `master` branch.
11+
12+## Project Setup
13+
14+See the `README.md` file on how to setup the project on your development machine.
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2016, Deni Bertovic
1+Copyright (c) 2014, Deni Bertovic
2
2
3All rights reserved.
3All rights reserved.
4
4
Makefile+22−7
@@ -1,4 +1,6 @@
1−.PHONY: build repl test release tag
1+.PHONY: build repl test release help
2+
3+.DEFAULT_GOAL = help
2
4
3PROJECT_NAME ?= $(shell grep "^name" docker.cabal | cut -d " " -f17)
5PROJECT_NAME ?= $(shell grep "^name" docker.cabal | cut -d " " -f17)
4VERSION ?= $(shell grep "^version:" docker.cabal | cut -d " " -f14)
6VERSION ?= $(shell grep "^version:" docker.cabal | cut -d " " -f14)
@@ -6,22 +8,35 @@ RESOLVER ?= $(shell grep "^resolver:" stack.yaml | cut -d " " -f2)
6GHC_VERSION ?= $(shell stack ghc -- --version | cut -d " " -f8)
8GHC_VERSION ?= $(shell stack ghc -- --version | cut -d " " -f8)
7ARCH=$(shell uname -m)
9ARCH=$(shell uname -m)
8
10
11+## Run build
9build:
12build:
10 @stack build
13 @stack build
11
14
15+## Run repl
12repl:
16repl:
13 @stack repl
17 @stack repl
14
18
19+## Run tests. Example RUN_INTEGRATION_TESTS=1 make test
15test:
20test:
16− @stack test
21+ @RUN_INTEGRATION_TESTS=1 stack test
17−
18−tag:
19− @echo Tagging version: ${VERSION}
20− @git tag ${VERSION}
21
22
23+## Cut new release
22−release: tag
24+release:
23 @stack build --haddock
25 @stack build --haddock
24 @stack sdist
26 @stack sdist
25 @echo "\n\nDone. Now run: \n\nstack upload <path_to_tarball>\n"
27 @echo "\n\nDone. Now run: \n\nstack upload <path_to_tarball>\n"
26 @echo "\nAnd: \n\ngit tag ${VERSION} && git push --tags\n"
28 @echo "\nAnd: \n\ngit tag ${VERSION} && git push --tags\n"
27
29
30+## Show help screen.
31+help:
32+ @echo "Please use \`make <target>' where <target> is one of\n\n"
33+ @awk '/^[a-zA-Z\-\_0-9]+:/ { \
34+ helpMessage = match(lastLine, /^## (.*)/); \
35+ if (helpMessage) { \
36+ helpCommand = substr($$1, 0, index($$1, ":")-1); \
37+ helpMessage = substr(lastLine, RSTART + 3, RLENGTH); \
38+ printf "%-30s %s\n", helpCommand, helpMessage; \
39+ } \
40+ } \
41+ { lastLine = $$0 }' $(MAKEFILE_LIST)
42+
README.md+26−9
@@ -7,25 +7,42 @@
7
7
8## Current state
8## Current state
9
9
10−**API is still not stable.**
11−
12−Supported Docker Engine Api version: `v1.24`
10+Supported Docker Engine Api version: `v1.24` and onwards.
13
11
14Anything upward of that should work since Docker versions their API.
12Anything upward of that should work since Docker versions their API.
15Older docker version and engine api versions are not supported at the moment.
13Older docker version and engine api versions are not supported at the moment.
16
14
15+## Documentation
16+
17+The API-documentation is available at
18+[Hackage](https://hackage.haskell.org/package/docker). There are also some
19+usage-examples in the main library source file,
20+[`Client.hs`](https://hackage.haskell.org/package/docker/docs/Docker-Client.html).
21+
17## Contributing
22## Contributing
18
23
19−If you wish to contribute please see any issue tagged with "help wanted".
24+Please see [CONTRIBUTING.md](CONTRIBUTING.md).
20−Make sure to submit your PR's against the `master` branch.
25+
26+### Project Setup
21
27
22−Please consider filling an Issue first and discuss design decisions and implementation details before
28+For working on the library, you need the Haskell Tool Stack installed (see [the
23−writing any code. This is so that no development cycles go to waste on implementing a feature that
29+Haskell Tool Stack
24−might not get merged either because of implementation details or other reasons.
30+website](https://docs.haskellstack.org/en/stable/install_and_upgrade/)). You
31+also need `make` to use the `Makefile` included in the project. Run `make help`
32+to see the available commands (for building, running the tests and releasing).
25
33
34+### Tests
35+
36+Tests are located in the `tests` directory and can be run with `make test`. This
37+only runs the unit tests.
38+
39+To run integration tests, you need Docker installed and listening on Port `2375`
40+of `localhost` (docker only listens to a Unix socket by default, see the [Docker
41+documentation](https://docs.docker.com/engine/reference/commandline/dockerd/#daemon-socket-option)
42+for details). Set the environment variable `RUN_INTEGRATION_TESTS`, i.e.
43+`RUN_INTEGRATION_TESTS=1 make test`.
26
44
27## IRC
45## IRC
28
46
29If you have any questions or suggestions you can find the maintainers in `#docker-haskell`
47If you have any questions or suggestions you can find the maintainers in `#docker-haskell`
30on freenode.
48on freenode.
31−
docker.cabal+26−12
@@ -1,5 +1,5 @@
1name: docker
1name: docker
2−version: 0.3.0.1
2+version: 0.6.0.3
3synopsis: An API client for docker written in Haskell
3synopsis: An API client for docker written in Haskell
4description: See API documentation below.
4description: See API documentation below.
5homepage: https://github.com/denibertovic/docker-hs
5homepage: https://github.com/denibertovic/docker-hs
@@ -14,24 +14,29 @@ extra-source-files: README.md
14cabal-version: >=1.10
14cabal-version: >=1.10
15stability: experimental
15stability: experimental
16
16
17+-- Flag small-http-conduit
18+-- Description: Resolve whether http-conduit < 2.3.0.
19+-- Manual: False
20+-- Default: True
21+
17library
22library
18− default-extensions: DeriveGeneric, OverloadedStrings, ScopedTypeVariables, ExplicitForAll, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes, DeriveFunctor, FlexibleInstances
23+ default-extensions: DeriveGeneric, OverloadedStrings, ScopedTypeVariables, ExplicitForAll, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes, DeriveFunctor, FlexibleInstances, CPP
19 hs-source-dirs: src
24 hs-source-dirs: src
20 exposed-modules: Docker.Client, Docker.Client.Api, Docker.Client.Types, Docker.Client.Internal, Docker.Client.Http, Docker.Client.Utils
25 exposed-modules: Docker.Client, Docker.Client.Api, Docker.Client.Types, Docker.Client.Internal, Docker.Client.Http, Docker.Client.Utils
21 -- other-modules: Docker.Internal
26 -- other-modules: Docker.Internal
22 build-depends: base >= 4.7 && < 5
27 build-depends: base >= 4.7 && < 5
23− , aeson >= 0.9.0 && < 1.1.0
28+ , aeson >= 0.9.0 && < 2.0.0
24 , blaze-builder >= 0.4.0 && < 0.5.0
29 , blaze-builder >= 0.4.0 && < 0.5.0
25 , bytestring >= 0.10.0 && < 0.11.0
30 , bytestring >= 0.10.0 && < 0.11.0
26− , containers >= 0.5.0 && < 0.6.0
31+ , containers >= 0.5.0 && < 0.7.0
27 , data-default-class >= 0.0.1 && < 0.2.0
32 , data-default-class >= 0.0.1 && < 0.2.0
28− , http-client >= 0.4.0 && < 0.5.0
33+ , http-client >= 0.4.0 && < 0.7.0
29− , http-types >= 0.9 && < 0.10.0
34+ , http-types >= 0.9 && < 0.13
35+ , vector
30 , conduit
36 , conduit
31 , conduit-combinators
37 , conduit-combinators
32 , conduit-extra
38 , conduit-extra
33 , exceptions
39 , exceptions
34− , http-conduit
35 , monad-control
40 , monad-control
36 , resourcet
41 , resourcet
37 , transformers
42 , transformers
@@ -46,13 +51,20 @@ library
46 , mtl >= 2.0.0 && < 3.0.0
51 , mtl >= 2.0.0 && < 3.0.0
47 , network >= 2.6.0
52 , network >= 2.6.0
48 , text >= 1.0.0 && < 2.0.0
53 , text >= 1.0.0 && < 2.0.0
49− , time >= 1.5.0 && < 1.7.0
54+ , time >= 1.5.0 && < 2.0.0
50 , scientific >= 0.3.0 && < 0.4.0
55 , scientific >= 0.3.0 && < 0.4.0
51− , tls >= 1.3.7 && < 1.4.0
56+ , tls >= 1.3.7 && < 1.6.0
52 , unordered-containers >= 0.2.0 && < 0.3.0
57 , unordered-containers >= 0.2.0 && < 0.3.0
53− , x509 >= 1.6.0 && < 1.7.0
58+ , x509 >= 1.6.0 && < 1.8.0
54− , x509-store >= 1.6.0 && < 1.7.0
59+ , x509-store >= 1.6.0 && < 1.8.0
55− , x509-system >= 1.6.0 && < 1.7.0
60+ , x509-system >= 1.6.0 && < 1.8.0
61+ , http-conduit
62+ , unliftio-core >= 0.1.0.0 && < 0.2.0
63+ -- if flag(small-http-conduit)
64+ -- build-depends: http-conduit < 2.3.0
65+ -- else
66+ -- build-depends: http-conduit >= 2.3.0
67+ -- , unliftio-core
56 default-language: Haskell2010
68 default-language: Haskell2010
57 ghc-options: -Wall -fno-warn-name-shadowing
69 ghc-options: -Wall -fno-warn-name-shadowing
58
70
@@ -61,6 +73,7 @@ test-suite docker-hs-tests
61 , bytestring
73 , bytestring
62 , connection
74 , connection
63 , docker
75 , docker
76+ , directory
64 , aeson
77 , aeson
65 , containers
78 , containers
66 , unordered-containers
79 , unordered-containers
@@ -76,6 +89,7 @@ test-suite docker-hs-tests
76 , transformers
89 , transformers
77 , QuickCheck
90 , QuickCheck
78 , process
91 , process
92+ , vector
79 type: exitcode-stdio-1.0
93 type: exitcode-stdio-1.0
80 main-is: tests.hs
94 main-is: tests.hs
81 hs-source-dirs: tests
95 hs-source-dirs: tests
src/Docker/Client.hs+1−1
@@ -3,7 +3,7 @@
3
3
4{-|
4{-|
5Module : Docker.Client
5Module : Docker.Client
6−Copyright : (c) Deni Bertovic, 2016
6+Copyright : (c) Deni Bertovic, 2014
7License : BSD3
7License : BSD3
8Maintainer : deni@denibertovic.com
8Maintainer : deni@denibertovic.com
9Stability : experimental
9Stability : experimental
src/Docker/Client/Api.hs+21−3
@@ -18,8 +18,12 @@ module Docker.Client.Api (
18 , getContainerLogsStream
18 , getContainerLogsStream
19 -- * Images
19 -- * Images
20 , listImages
20 , listImages
21+ , deleteImage
21 , buildImageFromDockerfile
22 , buildImageFromDockerfile
22 , pullImage
23 , pullImage
24+ -- * Network
25+ , createNetwork
26+ , removeNetwork
23 -- * Other
27 -- * Other
24 , getDockerVersion
28 , getDockerVersion
25 ) where
29 ) where
@@ -43,7 +47,7 @@ import Docker.Client.Types
43import Docker.Client.Utils
47import Docker.Client.Utils
44
48
45requestUnit :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())
49requestUnit :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())
46−requestUnit verb endpoint = const (Right ()) <$> requestHelper verb endpoint
50+requestUnit verb endpoint = fmap (const ()) <$> requestHelper verb endpoint
47
51
48requestHelper :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError BSL.ByteString)
52requestHelper :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError BSL.ByteString)
49requestHelper verb endpoint = requestHelper' verb endpoint Conduit.sinkLbs
53requestHelper verb endpoint = requestHelper' verb endpoint Conduit.sinkLbs
@@ -90,6 +94,12 @@ listContainers opts = requestHelper GET (ListContainersEndpoint opts) >>= parseR
90listImages :: 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])
91listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse
95listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse
92
96
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+
93-- | Creates a docker container but does __not__ start it. See
103-- | Creates a docker container but does __not__ start it. See
94-- 'CreateOpts' for a list of options and you can use 'defaultCreateOpts'
104-- 'CreateOpts' for a list of options and you can use 'defaultCreateOpts'
95-- for some sane defaults.
105-- for some sane defaults.
@@ -135,9 +145,9 @@ unpauseContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT
135unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid
145unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid
136
146
137-- | Deletes a container with the given 'ContainerID'.
147-- | Deletes a container with the given 'ContainerID'.
138−-- See "DeleteOpts" for options and use 'defaultDeleteOpts' for sane
148+-- See "ContainerDeleteOpts" for options and use 'defaultContainerDeleteOpts' for sane
139-- defaults.
149-- defaults.
140−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 ())
141deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid
151deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid
142
152
143-- | Gets 'ContainerDetails' for a given 'ContainerID'.
153-- | Gets 'ContainerDetails' for a given 'ContainerID'.
@@ -207,3 +217,11 @@ buildImageFromDockerfile opts base = do
207pullImage :: forall m b . (MonadIO m, MonadMask m) => T.Text -> Tag -> Sink BS.ByteString m b -> DockerT m (Either DockerError b)
217pullImage :: forall m b . (MonadIO m, MonadMask m) => T.Text -> Tag -> Sink BS.ByteString m b -> DockerT m (Either DockerError b)
208pullImage name tag = requestHelper' POST (CreateImageEndpoint name tag Nothing)
218pullImage name tag = requestHelper' POST (CreateImageEndpoint name tag Nothing)
209
219
220+-- | Creates network
221+createNetwork :: forall m. (MonadIO m, MonadMask m) => CreateNetworkOpts -> DockerT m (Either DockerError NetworkID)
222+createNetwork opts = requestHelper POST (CreateNetworkEndpoint opts) >>= parseResponse
223+
224+-- | Removes a network
225+removeNetwork :: forall m. (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError ())
226+removeNetwork nid = requestUnit DELETE $ RemoveNetworkEndpoint nid
227+
src/Docker/Client/Http.hs+40−7
@@ -5,6 +5,9 @@ module Docker.Client.Http where
5
5
6-- import Control.Monad.Base (MonadBase(..), liftBaseDefault)
6-- import Control.Monad.Base (MonadBase(..), liftBaseDefault)
7import Control.Monad.Catch (MonadMask (..))
7import Control.Monad.Catch (MonadMask (..))
8+#if MIN_VERSION_http_conduit(2,3,0)
9+import Control.Monad.IO.Unlift (MonadUnliftIO)
10+#endif
8import Control.Monad.Reader (ReaderT (..), runReaderT)
11import Control.Monad.Reader (ReaderT (..), runReaderT)
9import qualified Data.ByteString.Char8 as BSC
12import qualified Data.ByteString.Char8 as BSC
10import qualified Data.ByteString.Lazy as BL
13import qualified Data.ByteString.Lazy as BL
@@ -17,7 +20,7 @@ import Data.X509.CertificateStore (makeCertificateStore)
17import Data.X509.File (readKeyFile, readSignedObject)
20import Data.X509.File (readKeyFile, readSignedObject)
18import Network.HTTP.Client (defaultManagerSettings,
21import Network.HTTP.Client (defaultManagerSettings,
19 managerRawConnection, method,
22 managerRawConnection, method,
20− newManager, parseUrl,
23+ newManager, parseRequest,
21 requestBody, requestHeaders)
24 requestBody, requestHeaders)
22import qualified Network.HTTP.Client as HTTP
25import qualified Network.HTTP.Client as HTTP
23import Network.HTTP.Client.Internal (makeConnection)
26import Network.HTTP.Client.Internal (makeConnection)
@@ -94,7 +97,7 @@ runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
94mkHttpRequest :: HttpVerb -> Endpoint -> DockerClientOpts -> Maybe Request
97mkHttpRequest :: HttpVerb -> Endpoint -> DockerClientOpts -> Maybe Request
95mkHttpRequest verb e opts = request
98mkHttpRequest verb e opts = request
96 where fullE = T.unpack (baseUrl opts) ++ T.unpack (getEndpoint (apiVer opts) e)
99 where fullE = T.unpack (baseUrl opts) ++ T.unpack (getEndpoint (apiVer opts) e)
97− initialR = parseUrl fullE
100+ initialR = parseRequest fullE
98 request' = case initialR of
101 request' = case initialR of
99 Just ir ->
102 Just ir ->
100 return $ ir {method = (encodeUtf8 . T.pack $ show verb),
103 return $ ir {method = (encodeUtf8 . T.pack $ show verb),
@@ -104,18 +107,30 @@ mkHttpRequest verb e opts = request
104 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'
107 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'
105 -- Note: Do we need to set length header?
108 -- Note: Do we need to set length header?
106
109
110+defaultHttpHandler :: (
111+#if MIN_VERSION_http_conduit(2,3,0)
112+ MonadUnliftIO m,
113+#endif
107−defaultHttpHandler :: (MonadIO m, MonadMask m) => m (HttpHandler m)
114+ MonadIO m, MonadMask m) => m (HttpHandler m)
108defaultHttpHandler = do
115defaultHttpHandler = do
109 manager <- liftIO $ newManager defaultManagerSettings
116 manager <- liftIO $ newManager defaultManagerSettings
110 return $ httpHandler manager
117 return $ httpHandler manager
111
118
119+httpHandler :: (
120+#if MIN_VERSION_http_conduit(2,3,0)
121+ MonadUnliftIO m,
122+#endif
112−httpHandler :: (MonadIO m, MonadMask m) => HTTP.Manager -> HttpHandler m
123+ MonadIO m, MonadMask m) => HTTP.Manager -> HttpHandler m
113httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..
124httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..
114 let request = NHS.setRequestManager manager request'
125 let request = NHS.setRequestManager manager request'
115 try (NHS.httpSink request sink) >>= \res -> case res of
126 try (NHS.httpSink request sink) >>= \res -> case res of
116 Right res -> return res
127 Right res -> return res
128+#if MIN_VERSION_http_client(0,5,0)
129+ Left e@(HTTP.HttpExceptionRequest _ HTTP.ConnectionFailure{}) -> return $ Left $ DockerConnectionError e
130+#else
117 Left e@HTTP.FailedConnectionException{} -> return $ Left $ DockerConnectionError e
131 Left e@HTTP.FailedConnectionException{} -> return $ Left $ DockerConnectionError e
118 Left e@HTTP.FailedConnectionException2{} -> return $ Left $ DockerConnectionError e
132 Left e@HTTP.FailedConnectionException2{} -> return $ Left $ DockerConnectionError e
133+#endif
119 Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
134 Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
120
135
121-- | Connect to a unix domain socket (the default docker socket is
136-- | Connect to a unix domain socket (the default docker socket is
@@ -123,7 +138,11 @@ httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..
123--
138--
124-- Docker seems to ignore the hostname in requests sent over unix domain
139-- Docker seems to ignore the hostname in requests sent over unix domain
125-- sockets (and the port obviously doesn't matter either)
140-- sockets (and the port obviously doesn't matter either)
141+unixHttpHandler :: (
142+#if MIN_VERSION_http_conduit(2,3,0)
143+ MonadUnliftIO m,
144+#endif
126−unixHttpHandler :: (MonadIO m, MonadMask m) => FilePath -- ^ The socket to connect to
145+ MonadIO m, MonadMask m) => FilePath -- ^ The socket to connect to
127 -> m (HttpHandler m)
146 -> m (HttpHandler m)
128unixHttpHandler fp = do
147unixHttpHandler fp = do
129 let mSettings = defaultManagerSettings
148 let mSettings = defaultManagerSettings
@@ -137,7 +156,7 @@ unixHttpHandler fp = do
137 S.connect s (S.SockAddrUnix filePath)
156 S.connect s (S.SockAddrUnix filePath)
138 makeConnection (SBS.recv s 8096)
157 makeConnection (SBS.recv s 8096)
139 (SBS.sendAll s)
158 (SBS.sendAll s)
140− (S.sClose s)
159+ (S.close s)
141
160
142-- TODO:
161-- TODO:
143-- Move this to http-client-tls or network?
162-- Move this to http-client-tls or network?
@@ -254,4 +273,18 @@ statusCodeToError (CreateImageEndpoint _ _ _) st =
254 Nothing
273 Nothing
255 else
274 else
256 Just $ DockerInvalidStatusCode st
275 Just $ DockerInvalidStatusCode st
257−
276+statusCodeToError (DeleteImageEndpoint _ _) st =
277+ if st == status200 then
278+ Nothing
279+ else
280+ Just $ DockerInvalidStatusCode st
281+statusCodeToError (CreateNetworkEndpoint _) st =
282+ if st == status201 then
283+ Nothing
284+ else
285+ Just $ DockerInvalidStatusCode st
286+statusCodeToError (RemoveNetworkEndpoint _) st =
287+ if st == status204 then
288+ Nothing
289+ else
290+ Just $ DockerInvalidStatusCode st
src/Docker/Client/Internal.hs+11−3
@@ -5,12 +5,13 @@ import qualified Data.Aeson as JSON
5import Data.ByteString (ByteString)
5import Data.ByteString (ByteString)
6import qualified Data.ByteString.Char8 as BSC
6import qualified Data.ByteString.Char8 as BSC
7import qualified Data.Conduit.Binary as CB
7import qualified Data.Conduit.Binary as CB
8−import Data.Text as T
8+import qualified Data.Text as T
9import Data.Text.Encoding (decodeUtf8, encodeUtf8)
9import Data.Text.Encoding (decodeUtf8, encodeUtf8)
10import qualified Network.HTTP.Client as HTTP
10import qualified Network.HTTP.Client as HTTP
11import Network.HTTP.Conduit (requestBodySourceChunked)
11import Network.HTTP.Conduit (requestBodySourceChunked)
12import Network.HTTP.Types (Query, encodePath,
12import Network.HTTP.Types (Query, encodePath,
13 encodePathSegments)
13 encodePathSegments)
14+import Prelude hiding (all)
14
15
15import Docker.Client.Types
16import Docker.Client.Types
16
17
@@ -26,7 +27,7 @@ encodeQ = encodeUtf8 . T.pack
26
27
27getEndpoint :: ApiVersion -> Endpoint -> T.Text
28getEndpoint :: ApiVersion -> Endpoint -> T.Text
28getEndpoint v VersionEndpoint = encodeURL [v, "version"]
29getEndpoint v VersionEndpoint = encodeURL [v, "version"]
29−getEndpoint v (ListContainersEndpoint _) = encodeURL [v, "containers", "json"] -- Make use of lsOpts here
30+getEndpoint v (ListContainersEndpoint (ListOpts all)) = encodeURLWithQuery [v, "containers", "json"] [("all", Just (encodeQ $ show all))]
30getEndpoint v (ListImagesEndpoint _) = encodeURL [v, "images", "json"] -- Make use of lsOpts here
31getEndpoint v (ListImagesEndpoint _) = encodeURL [v, "images", "json"] -- Make use of lsOpts here
31getEndpoint v (CreateContainerEndpoint _ cn) = case cn of
32getEndpoint v (CreateContainerEndpoint _ cn) = case cn of
32 Just cn -> encodeURLWithQuery [v, "containers", "create"] [("name", Just (encodeQ $ T.unpack cn))]
33 Just cn -> encodeURLWithQuery [v, "containers", "create"] [("name", Just (encodeQ $ T.unpack cn))]
@@ -56,7 +57,7 @@ getEndpoint v (UnpauseContainerEndpoint cid) = encodeURL [v, "containers", fromC
56getEndpoint v (ContainerLogsEndpoint (LogOpts stdout stderr _ _ _) follow cid) =
57getEndpoint v (ContainerLogsEndpoint (LogOpts stdout stderr _ _ _) follow cid) =
57 encodeURLWithQuery [v, "containers", fromContainerID cid, "logs"] query
58 encodeURLWithQuery [v, "containers", fromContainerID cid, "logs"] query
58 where query = [("stdout", Just (encodeQ $ show stdout)), ("stderr", Just (encodeQ $ show stderr)), ("follow", Just (encodeQ $ show follow))]
59 where query = [("stdout", Just (encodeQ $ show stdout)), ("stderr", Just (encodeQ $ show stderr)), ("follow", Just (encodeQ $ show follow))]
59−getEndpoint v (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =
60+getEndpoint v (DeleteContainerEndpoint (ContainerDeleteOpts removeVolumes force) cid) =
60 encodeURLWithQuery [v, "containers", fromContainerID cid] query
61 encodeURLWithQuery [v, "containers", fromContainerID cid] query
61 where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))]
62 where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))]
62getEndpoint v (InspectContainerEndpoint cid) =
63getEndpoint v (InspectContainerEndpoint cid) =
@@ -74,6 +75,9 @@ getEndpoint v (CreateImageEndpoint name tag _) = encodeURLWithQuery [v, "images"
74 where query = [("fromImage", Just n), ("tag", Just t)]
75 where query = [("fromImage", Just n), ("tag", Just t)]
75 n = encodeQ $ T.unpack name
76 n = encodeQ $ T.unpack name
76 t = encodeQ $ T.unpack tag
77 t = encodeQ $ T.unpack tag
78+getEndpoint v (DeleteImageEndpoint _ cid) = encodeURL [v, "images", fromImageID cid]
79+getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"]
80+getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid]
77
81
78getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody
82getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody
79getEndpointRequestBody VersionEndpoint = Nothing
83getEndpointRequestBody VersionEndpoint = Nothing
@@ -93,6 +97,10 @@ getEndpointRequestBody (InspectContainerEndpoint _) = Nothing
93
97
94getEndpointRequestBody (BuildImageEndpoint _ fp) = Just $ requestBodySourceChunked $ CB.sourceFile fp
98getEndpointRequestBody (BuildImageEndpoint _ fp) = Just $ requestBodySourceChunked $ CB.sourceFile fp
95getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing
99getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing
100+getEndpointRequestBody (DeleteImageEndpoint _ _) = Nothing
101+
102+getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)
103+getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing
96
104
97getEndpointContentType :: Endpoint -> BSC.ByteString
105getEndpointContentType :: Endpoint -> BSC.ByteString
98getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar"
106getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar"
src/Docker/Client/Types.hs+170−45
@@ -11,6 +11,9 @@ module Docker.Client.Types (
11 , ImageID
11 , ImageID
12 , fromImageID
12 , fromImageID
13 , toImageID
13 , toImageID
14+ , NetworkID
15+ , fromNetworkID
16+ , toNetworkID
14 , Timeout(..)
17 , Timeout(..)
15 , StatusCode(..)
18 , StatusCode(..)
16 , Signal(..)
19 , Signal(..)
@@ -23,11 +26,12 @@ module Docker.Client.Types (
23 , ContainerPortInfo(..)
26 , ContainerPortInfo(..)
24 , Container(..)
27 , Container(..)
25 , ContainerState(..)
28 , ContainerState(..)
26− , Status(..)
29+ , State(..)
27 , Digest
30 , Digest
28 , Label(..)
31 , Label(..)
29 , Tag
32 , Tag
30 , Image(..)
33 , Image(..)
34+ , Entrypoint(..)
31 , dropImagePrefix
35 , dropImagePrefix
32 , CreateOpts(..)
36 , CreateOpts(..)
33 , BuildOpts(..)
37 , BuildOpts(..)
@@ -36,12 +40,16 @@ module Docker.Client.Types (
36 , DetachKeys(..)
40 , DetachKeys(..)
37 , StartOpts(..)
41 , StartOpts(..)
38 , defaultStartOpts
42 , defaultStartOpts
39− , DeleteOpts(..)
43+ , ContainerDeleteOpts(..)
40− , defaultDeleteOpts
44+ , defaultContainerDeleteOpts
45+ , ImageDeleteOpts(..)
46+ , defaultImageDeleteOpts
41 , Timestamp
47 , Timestamp
42 , TailLogOpt(..)
48 , TailLogOpt(..)
43 , LogOpts(..)
49 , LogOpts(..)
44 , defaultLogOpts
50 , defaultLogOpts
51+ , CreateNetworkOpts(..)
52+ , defaultCreateNetworkOpts
45 , VolumePermission(..)
53 , VolumePermission(..)
46 , Bind(..)
54 , Bind(..)
47 , Volume(..)
55 , Volume(..)
@@ -67,6 +75,8 @@ module Docker.Client.Types (
67 , UTSMode(..)
75 , UTSMode(..)
68 , HostConfig(..)
76 , HostConfig(..)
69 , defaultHostConfig
77 , defaultHostConfig
78+ , NetworkingConfig(..)
79+ , EndpointConfig(..)
70 , Ulimit(..)
80 , Ulimit(..)
71 , ContainerResources(..)
81 , ContainerResources(..)
72 , defaultContainerResources
82 , defaultContainerResources
@@ -102,6 +112,7 @@ import Data.Scientific (floatingOrInteger)
102import Data.Text (Text)
112import Data.Text (Text)
103import qualified Data.Text as T
113import qualified Data.Text as T
104import Data.Time.Clock (UTCTime)
114import Data.Time.Clock (UTCTime)
115+import qualified Data.Vector as V
105import GHC.Generics (Generic)
116import GHC.Generics (Generic)
106import Prelude hiding (all, tail)
117import Prelude hiding (all, tail)
107import Text.Read (readMaybe)
118import Text.Read (readMaybe)
@@ -121,10 +132,13 @@ data Endpoint =
121 | UnpauseContainerEndpoint ContainerID
132 | UnpauseContainerEndpoint ContainerID
122 | 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.
123 -- See note in 'Docker.Client.Api.getContainerLogs' for explanation why.
134 -- See note in 'Docker.Client.Api.getContainerLogs' for explanation why.
124− | DeleteContainerEndpoint DeleteOpts ContainerID
135+ | DeleteContainerEndpoint ContainerDeleteOpts ContainerID
125 | InspectContainerEndpoint ContainerID
136 | InspectContainerEndpoint ContainerID
126 | BuildImageEndpoint BuildOpts FilePath
137 | BuildImageEndpoint BuildOpts FilePath
127 | 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
140+ | CreateNetworkEndpoint CreateNetworkOpts
141+ | RemoveNetworkEndpoint NetworkID
128 deriving (Eq, Show)
142 deriving (Eq, Show)
129
143
130-- | We should newtype this
144-- | We should newtype this
@@ -236,7 +250,7 @@ data ContainerDetails = ContainerDetails {
236 , processLabel :: Text
250 , processLabel :: Text
237 , resolveConfPath :: FilePath
251 , resolveConfPath :: FilePath
238 , restartCount :: Int
252 , restartCount :: Int
239− , state :: ContainerState
253+ , containerDetailsState :: ContainerState
240 , mounts :: [Mount]
254 , mounts :: [Mount]
241 }
255 }
242 deriving (Eq, Show, Generic)
256 deriving (Eq, Show, Generic)
@@ -244,11 +258,11 @@ data ContainerDetails = ContainerDetails {
244-- | Data type used for parsing the mount information from a container
258-- | Data type used for parsing the mount information from a container
245-- list.
259-- list.
246data Mount = Mount {
260data Mount = Mount {
247− mountName :: Text
261+ mountName :: Maybe Text -- this is optional
248 , mountSource :: FilePath
262 , mountSource :: FilePath
249 , mountDestination :: FilePath
263 , mountDestination :: FilePath
250− , mountDriver :: Text
264+ , mountDriver :: Maybe Text
251− , mountMode :: Maybe VolumePermission -- apparently this can be null
265+ -- , mountMode :: Maybe VolumePermission -- apparently this can be null
252 , mountRW :: Bool
266 , mountRW :: Bool
253 , mountPropogation :: Text
267 , mountPropogation :: Text
254 }
268 }
@@ -256,14 +270,14 @@ data Mount = Mount {
256
270
257instance FromJSON Mount where
271instance FromJSON Mount where
258 parseJSON (JSON.Object o) = do
272 parseJSON (JSON.Object o) = do
259− name <- o .: "Name"
273+ name <- o .:? "Name"
260 src <- o .: "Source"
274 src <- o .: "Source"
261 dest <- o .: "Destination"
275 dest <- o .: "Destination"
262− driver <- o .: "Driver"
276+ driver <- o .:? "Driver"
263− mode <- o .: "Mode"
277+ -- mode <- o .: "Mode"
264 rw <- o .: "RW"
278 rw <- o .: "RW"
265 prop <- o .: "Propagation"
279 prop <- o .: "Propagation"
266− return $ Mount name src dest driver mode rw prop
280+ return $ Mount name src dest driver rw prop
267 parseJSON _ = fail "Mount is not an object"
281 parseJSON _ = fail "Mount is not an object"
268
282
269-- | Data type used for parsing the container state from a list of
283-- | Data type used for parsing the container state from a list of
@@ -279,7 +293,7 @@ data ContainerState = ContainerState {
279 , restarting :: Bool
293 , restarting :: Bool
280 , running :: Bool
294 , running :: Bool
281 , startedAt :: UTCTime
295 , startedAt :: UTCTime
282− , status :: Status
296+ , state :: State
283 }
297 }
284 deriving (Eq, Show, Generic)
298 deriving (Eq, Show, Generic)
285
299
@@ -509,7 +523,8 @@ data Container = Container
509 , containerImageId :: ImageID
523 , containerImageId :: ImageID
510 , containerCommand :: Text
524 , containerCommand :: Text
511 , containerCreatedAt :: Int
525 , containerCreatedAt :: Int
526+ , containerState :: State
512− , containerStatus :: Status
527+ , containerStatus :: Maybe Text
513 , containerPorts :: [ContainerPortInfo]
528 , containerPorts :: [ContainerPortInfo]
514 , containerLabels :: [Label]
529 , containerLabels :: [Label]
515 , containerNetworks :: [Network]
530 , containerNetworks :: [Network]
@@ -517,13 +532,14 @@ data Container = Container
517 } deriving (Show, Eq)
532 } deriving (Show, Eq)
518
533
519instance FromJSON Container where
534instance FromJSON Container where
520− parseJSON (JSON.Object v) =
535+ parseJSON o@(JSON.Object v) =
521− Container <$> (v .: "Id")
536+ Container <$> parseJSON o
522 <*> (v .: "Names")
537 <*> (v .: "Names")
523 <*> (v .: "Image")
538 <*> (v .: "Image")
524− <*> (v .: "ImageID")
539+ <*> (v .: "ImageID") -- Doesn't exist anymore
525− <*> (v .: "Command")
540+ <*> (v .: "Command") -- Doesn't exist anymore
526 <*> (v .: "Created")
541 <*> (v .: "Created")
542+ <*> (v .: "State")
527 <*> (v .: "Status")
543 <*> (v .: "Status")
528 <*> (v .: "Ports")
544 <*> (v .: "Ports")
529 <*> (v .: "Labels")
545 <*> (v .: "Labels")
@@ -533,21 +549,20 @@ instance FromJSON Container where
533 parseNetworks (JSON.Object v) =
549 parseNetworks (JSON.Object v) =
534 (v .: "Networks") >>= parseJSON
550 (v .: "Networks") >>= parseJSON
535 parseNetworks _ = fail "Container NetworkSettings: Not a JSON object."
551 parseNetworks _ = fail "Container NetworkSettings: Not a JSON object."
536−
537 parseJSON _ = fail "Container: Not a JSON object."
552 parseJSON _ = fail "Container: Not a JSON object."
538
553
539−-- | Represents the status of the container life cycle.
554+-- | Represents the state of the container life cycle.
540−data Status = Created | Restarting | Running | Paused | Exited | Dead
555+data State = Created | Restarting | Running | Paused | Exited | Dead
541 deriving (Eq, Show, Generic)
556 deriving (Eq, Show, Generic)
542
557
543−instance FromJSON Status where
558+instance FromJSON State where
544 parseJSON (JSON.String "running") = return Running
559 parseJSON (JSON.String "running") = return Running
545 parseJSON (JSON.String "created") = return Created -- Note: Guessing on the string values of these.
560 parseJSON (JSON.String "created") = return Created -- Note: Guessing on the string values of these.
546 parseJSON (JSON.String "restarting") = return Restarting
561 parseJSON (JSON.String "restarting") = return Restarting
547 parseJSON (JSON.String "paused") = return Paused
562 parseJSON (JSON.String "paused") = return Paused
548 parseJSON (JSON.String "exited") = return Exited
563 parseJSON (JSON.String "exited") = return Exited
549 parseJSON (JSON.String "dead") = return Dead
564 parseJSON (JSON.String "dead") = return Dead
550− parseJSON _ = fail "Unknown Status"
565+ parseJSON s = fail $ "Unknown Status: " ++ show s
551
566
552-- | Alias for representing a RepoDigest. We could newtype this and add
567-- | Alias for representing a RepoDigest. We could newtype this and add
553-- some validation.
568-- some validation.
@@ -608,20 +623,46 @@ instance FromJSON Image where
608 return $ DockerImage imageId imageCreated imageParentId imageRepoTags imageRepoDigests imageSize imageVirtualSize imageLabels
623 return $ DockerImage imageId imageCreated imageParentId imageRepoTags imageRepoDigests imageSize imageVirtualSize imageLabels
609 parseJSON _ = fail "Failed to parse DockerImage."
624 parseJSON _ = fail "Failed to parse DockerImage."
610
625
626+-- | Alias for Aliases.
627+type Alias = Text
628+
629+-- | EndpointsConfig is container configuration for a specific network
630+newtype EndpointConfig = EndpointConfig [Alias] deriving (Eq, Show)
631+
632+instance ToJSON EndpointConfig where
633+ toJSON (EndpointConfig aliases) = JSON.object
634+ [ "Aliases" .= aliases
635+ ]
636+
637+-- | Alias for endpoint name
638+type EndpointName = Text
639+
640+-- | Data type for the NetworkingConfig section of the container settings
641+newtype NetworkingConfig = NetworkingConfig
642+ { endpointsConfig :: HM.HashMap EndpointName EndpointConfig
643+ } deriving (Eq, Show)
644+
645+instance ToJSON NetworkingConfig where
646+ toJSON (NetworkingConfig endpointsConfig) = JSON.object
647+ [ "EndpointsConfig" .= endpointsConfig
648+ ]
611
649
612-- | Options used for creating a Container.
650-- | Options used for creating a Container.
613data CreateOpts = CreateOpts {
651data CreateOpts = CreateOpts {
614− containerConfig :: ContainerConfig
652+ containerConfig :: ContainerConfig
615− , hostConfig :: HostConfig
653+ , hostConfig :: HostConfig
654+ , networkingConfig :: NetworkingConfig
616 } deriving (Eq, Show)
655 } deriving (Eq, Show)
617
656
618instance ToJSON CreateOpts where
657instance ToJSON CreateOpts where
619− toJSON (CreateOpts cc hc) = do
658+ toJSON (CreateOpts cc hc nc) = do
620 let ccJSON = toJSON cc
659 let ccJSON = toJSON cc
621 let hcJSON = toJSON hc
660 let hcJSON = toJSON hc
622 case ccJSON of
661 case ccJSON of
623 JSON.Object (o :: HM.HashMap T.Text JSON.Value) -> do
662 JSON.Object (o :: HM.HashMap T.Text JSON.Value) -> do
624− JSON.Object $ HM.insert "HostConfig" hcJSON o
663+ let o1 = HM.insert "HostConfig" hcJSON o
664+ let o2 = HM.insert "NetworkingConfig" (toJSON nc) o1
665+ JSON.Object o2
625 _ -> error "ContainerConfig is not an object." -- This should never happen.
666 _ -> error "ContainerConfig is not an object." -- This should never happen.
626
667
627-- | Container configuration used for creating a container with sensible
668-- | Container configuration used for creating a container with sensible
@@ -643,7 +684,7 @@ defaultContainerConfig imageName = ContainerConfig {
643 , cmd=[]
684 , cmd=[]
644 , volumes=[]
685 , volumes=[]
645 , workingDir=Nothing
686 , workingDir=Nothing
646− , entrypoint=Nothing
687+ , entrypoint=Entrypoint []
647 , networkDisabled=Nothing
688 , networkDisabled=Nothing
648 , macAddress=Nothing
689 , macAddress=Nothing
649 , labels=[]
690 , labels=[]
@@ -656,7 +697,7 @@ defaultHostConfig = HostConfig {
656 binds=[]
697 binds=[]
657 , containerIDFile=Nothing
698 , containerIDFile=Nothing
658 , logConfig=LogDriverConfig JsonFile []
699 , logConfig=LogDriverConfig JsonFile []
659− , networkMode=Bridge
700+ , networkMode=NetworkBridge
660 , portBindings=[]
701 , portBindings=[]
661 , restartPolicy=RestartOff
702 , restartPolicy=RestartOff
662 , volumeDriver=Nothing
703 , volumeDriver=Nothing
@@ -696,14 +737,18 @@ defaultContainerResources = ContainerResources {
696 , memory=Nothing
737 , memory=Nothing
697 , memoryReservation=Nothing
738 , memoryReservation=Nothing
698 , memorySwap=Nothing
739 , memorySwap=Nothing
699− , oomKillDisable=False
740+ , oomKillDisable=Just False
700 , ulimits=[]
741 , ulimits=[]
701 }
742 }
702
743
703-- | Default create options when creating a container. You only need to
744-- | Default create options when creating a container. You only need to
704-- specify an image name and the rest is all sensible defaults.
745-- specify an image name and the rest is all sensible defaults.
705defaultCreateOpts :: T.Text -> CreateOpts
746defaultCreateOpts :: T.Text -> CreateOpts
747+defaultCreateOpts imageName = CreateOpts
706−defaultCreateOpts imageName = CreateOpts { containerConfig = defaultContainerConfig imageName, hostConfig = defaultHostConfig }
748+ { containerConfig = defaultContainerConfig imageName
749+ , hostConfig = defaultHostConfig
750+ , networkingConfig = NetworkingConfig HM.empty
751+ }
707
752
708-- | Override the key sequence for detaching a container.
753-- | Override the key sequence for detaching a container.
709-- Format is a single character [a-Z] or ctrl-<value> where <value> is one of: a-z, @, ^, [, , or _.
754-- Format is a single character [a-Z] or ctrl-<value> where <value> is one of: a-z, @, ^, [, , or _.
@@ -717,7 +762,7 @@ defaultStartOpts :: StartOpts
717defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }
762defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }
718
763
719-- | Options for deleting a container.
764-- | Options for deleting a container.
720−data DeleteOpts = DeleteOpts {
765+data ContainerDeleteOpts = ContainerDeleteOpts {
721 deleteVolumes :: Bool -- ^ Automatically cleanup volumes that the container created as well.
766 deleteVolumes :: Bool -- ^ Automatically cleanup volumes that the container created as well.
722 , force :: Bool -- ^ If the container is still running force deletion anyway.
767 , force :: Bool -- ^ If the container is still running force deletion anyway.
723 } deriving (Eq, Show)
768 } deriving (Eq, Show)
@@ -747,8 +792,15 @@ defaultBuildOpts nameTag = BuildOpts { buildImageName = nameTag
747-- | 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
748-- 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
749-- running.
794-- running.
750−defaultDeleteOpts :: DeleteOpts
795+defaultContainerDeleteOpts :: ContainerDeleteOpts
751−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
752
804
753-- | Timestamp alias.
805-- | Timestamp alias.
754type Timestamp = Integer
806type Timestamp = Integer
@@ -776,6 +828,36 @@ defaultLogOpts = LogOpts { stdout = True
776 , tail = All
828 , tail = All
777 }
829 }
778
830
831+-- | Options for creating a network
832+data CreateNetworkOpts = CreateNetworkOpts
833+ { createNetworkName :: Text -- ^ The network's name
834+ , createNetworkCheckDuplicate :: Bool -- ^ Check for networks with duplicate names.
835+ , createNetworkDriver :: Text -- ^ Name of the network driver plugin to use.
836+ , createNetworkInternal :: Bool -- ^ Restrict external access to the network.
837+ , createNetworkEnableIPv6 :: Bool -- ^ Enable IPv6 on the network.
838+ } deriving (Eq, Show)
839+
840+-- | Sensible defalut for create network options
841+defaultCreateNetworkOpts :: Text -> CreateNetworkOpts
842+defaultCreateNetworkOpts name =
843+ CreateNetworkOpts
844+ { createNetworkName = name
845+ , createNetworkCheckDuplicate = False
846+ , createNetworkDriver = "bridge"
847+ , createNetworkInternal = True
848+ , createNetworkEnableIPv6 = False
849+ }
850+
851+instance ToJSON CreateNetworkOpts where
852+ toJSON opts =
853+ object
854+ [ "Name" .= createNetworkName opts
855+ , "CheckDuplicate" .= createNetworkCheckDuplicate opts
856+ , "Driver" .= createNetworkDriver opts
857+ , "Internal" .= createNetworkInternal opts
858+ , "EnableIPv6" .= createNetworkEnableIPv6 opts
859+ ]
860+
779-- TOOD: Add support for SELinux Volume labels (eg. "ro,z" or "ro/Z")
861-- TOOD: Add support for SELinux Volume labels (eg. "ro,z" or "ro/Z")
780-- | Set permissions on volumes that you mount in the container.
862-- | Set permissions on volumes that you mount in the container.
781data VolumePermission = ReadWrite | ReadOnly deriving (Eq, Show, Generic)
863data VolumePermission = ReadWrite | ReadOnly deriving (Eq, Show, Generic)
@@ -787,6 +869,8 @@ instance ToJSON VolumePermission where
787instance FromJSON VolumePermission where
869instance FromJSON VolumePermission where
788 parseJSON "rw" = return ReadWrite
870 parseJSON "rw" = return ReadWrite
789 parseJSON "ro" = return ReadOnly
871 parseJSON "ro" = return ReadOnly
872+ parseJSON "RW" = return ReadWrite
873+ parseJSON "RO" = return ReadOnly
790 parseJSON _ = fail "Failed to parse VolumePermission"
874 parseJSON _ = fail "Failed to parse VolumePermission"
791
875
792-- | Used for marking a directory in the container as "exposed" hence
876-- | Used for marking a directory in the container as "exposed" hence
@@ -933,19 +1017,41 @@ instance FromJSON LogDriverConfig where
933 parseJSON _ = fail "LogDriverConfig is not an object"
1017 parseJSON _ = fail "LogDriverConfig is not an object"
934
1018
935-- TODO: Add container:<name|id> mode
1019-- TODO: Add container:<name|id> mode
936−data NetworkMode = Bridge | Host | NetworkDisabled
1020+data NetworkMode = NetworkBridge | NetworkHost | NetworkDisabled | NetworkNamed Text
937 deriving (Eq, Show, Ord)
1021 deriving (Eq, Show, Ord)
938
1022
939instance FromJSON NetworkMode where
1023instance FromJSON NetworkMode where
940− parseJSON (JSON.String "bridge") = return Bridge
1024+ parseJSON (JSON.String "bridge") = return NetworkBridge
941− parseJSON (JSON.String "host") = return Host -- Note: Guessing on these.
1025+ parseJSON (JSON.String "host") = return NetworkHost -- Note: Guessing on these.
942 parseJSON (JSON.String "none") = return NetworkDisabled
1026 parseJSON (JSON.String "none") = return NetworkDisabled
1027+ parseJSON (JSON.String n) = return $ NetworkNamed n
943 parseJSON _ = fail "Unknown NetworkMode"
1028 parseJSON _ = fail "Unknown NetworkMode"
944
1029
945instance ToJSON NetworkMode where
1030instance ToJSON NetworkMode where
946− toJSON Bridge = JSON.String "bridge"
1031+ toJSON NetworkBridge = JSON.String "bridge"
947− toJSON Host = JSON.String "host"
1032+ toJSON NetworkHost = JSON.String "host"
948− toJSON NetworkDisabled = JSON.String "none"
1033+ toJSON NetworkDisabled = JSON.String "none"
1034+ toJSON (NetworkNamed n) = JSON.String n
1035+
1036+newtype NetworkID = NetworkID Text
1037+ deriving (Eq, Show)
1038+
1039+-- | Used for extracting the id of the container from the newtype
1040+fromNetworkID :: NetworkID -> Text
1041+fromNetworkID (NetworkID t) = t
1042+
1043+-- | Used for parsing a Text value into a NetworkID.
1044+toNetworkID :: Text -> Maybe NetworkID
1045+toNetworkID t = Just $ NetworkID t
1046+
1047+instance FromJSON NetworkID where
1048+ parseJSON (JSON.Object o) = do
1049+ nid <- o .: "Id"
1050+ return $ NetworkID nid
1051+ parseJSON _ = fail "NetworkID is not an object."
1052+
1053+instance ToJSON NetworkID where
1054+ toJSON (NetworkID nid) = object ["Id" .= nid]
949
1055
950data PortType = TCP | UDP deriving (Eq, Generic, Read, Ord)
1056data PortType = TCP | UDP deriving (Eq, Generic, Read, Ord)
951
1057
@@ -1308,7 +1414,7 @@ data ContainerResources = ContainerResources {
1308 , memoryReservation :: Maybe MemoryConstraint
1414 , memoryReservation :: Maybe MemoryConstraint
1309 , memorySwap :: Maybe MemoryConstraint
1415 , memorySwap :: Maybe MemoryConstraint
1310 -- , memorySwappiness :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.
1416 -- , memorySwappiness :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.
1311− , oomKillDisable :: Bool
1417+ , oomKillDisable :: Maybe Bool
1312 -- , pidsLimit :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.
1418 -- , pidsLimit :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.
1313 , ulimits :: [Ulimit]
1419 , ulimits :: [Ulimit]
1314 -- TODO: Missing from 1.24
1420 -- TODO: Missing from 1.24
@@ -1346,7 +1452,7 @@ instance FromJSON EnvVar where
1346 parseJSON _ = fail "EnvVar is not a string"
1452 parseJSON _ = fail "EnvVar is not a string"
1347
1453
1348instance ToJSON EnvVar where
1454instance ToJSON EnvVar where
1349− toJSON (EnvVar n v) = object [n .= v]
1455+ toJSON (EnvVar n v) = JSON.String $ n <> T.pack "=" <> v
1350
1456
1351-- | ExposedPort represents a port (and it's type)
1457-- | ExposedPort represents a port (and it's type)
1352-- that a container should expose to other containers or the host system.
1458-- that a container should expose to other containers or the host system.
@@ -1386,6 +1492,21 @@ instance {-# OVERLAPPING #-} ToJSON [ExposedPort] where
1386 where key (ExposedPort p t) = show p <> slash <> show t
1492 where key (ExposedPort p t) = show p <> slash <> show t
1387 slash = T.unpack "/"
1493 slash = T.unpack "/"
1388
1494
1495+data Entrypoint = Entrypoint [T.Text] deriving (Eq, Show, Generic)
1496+
1497+instance ToJSON Entrypoint where
1498+ toJSON (Entrypoint (e:es)) = toJSON (e:es)
1499+ toJSON (Entrypoint []) = JSON.Null
1500+
1501+instance FromJSON Entrypoint where
1502+ parseJSON (JSON.String e) = return $ Entrypoint [e]
1503+ parseJSON (JSON.Array ar) = do
1504+ arr <- mapM parseJSON (V.toList ar)
1505+ return $ Entrypoint arr
1506+ parseJSON JSON.Null = return $ Entrypoint []
1507+ parseJSON _ = fail "Failed to parse Entrypoint"
1508+
1509+
1389data ContainerConfig = ContainerConfig {
1510data ContainerConfig = ContainerConfig {
1390 hostname :: Maybe Text
1511 hostname :: Maybe Text
1391 , domainname :: Maybe Text
1512 , domainname :: Maybe Text
@@ -1404,7 +1525,7 @@ data ContainerConfig = ContainerConfig {
1404 , image :: Text
1525 , image :: Text
1405 , volumes :: [Volume]
1526 , volumes :: [Volume]
1406 , workingDir :: Maybe FilePath
1527 , workingDir :: Maybe FilePath
1407− , entrypoint :: Maybe Text -- Can be null?
1528+ , entrypoint :: Entrypoint
1408 , networkDisabled :: Maybe Bool -- Note: Should we expand the JSON instance and take away the Maybe? Null is False?
1529 , networkDisabled :: Maybe Bool -- Note: Should we expand the JSON instance and take away the Maybe? Null is False?
1409 , macAddress :: Maybe Text
1530 , macAddress :: Maybe Text
1410 -- , onBuild :: Maybe Text -- For 1.24, only see this in the inspect response.
1531 -- , onBuild :: Maybe Text -- For 1.24, only see this in the inspect response.
@@ -1412,6 +1533,7 @@ data ContainerConfig = ContainerConfig {
1412 , stopSignal :: Signal
1533 , stopSignal :: Signal
1413 } deriving (Eq, Show, Generic)
1534 } deriving (Eq, Show, Generic)
1414
1535
1536+
1415instance ToJSON ContainerConfig where
1537instance ToJSON ContainerConfig where
1416 toJSON = genericToJSON defaultOptions {
1538 toJSON = genericToJSON defaultOptions {
1417 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
1539 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
@@ -1433,7 +1555,7 @@ instance FromJSON ContainerConfig where
1433 image <- o .: "Image"
1555 image <- o .: "Image"
1434 volumes <- o .: "Volumes"
1556 volumes <- o .: "Volumes"
1435 workingDir <- o .:? "WorkingDir"
1557 workingDir <- o .:? "WorkingDir"
1436− entrypoint <- o .:? "Entrypoint"
1558+ entrypoint <- o .: "Entrypoint"
1437 networkDisabled <- o .:? "networkDisabled"
1559 networkDisabled <- o .:? "networkDisabled"
1438 macAddress <- o .:? "MacAddress"
1560 macAddress <- o .:? "MacAddress"
1439 labels <- o .:? "Labels" .!= []
1561 labels <- o .:? "Labels" .!= []
@@ -1442,7 +1564,11 @@ instance FromJSON ContainerConfig where
1442 macAddress labels stopSignal
1564 macAddress labels stopSignal
1443 parseJSON _ = fail "NetworkSettings is not an object."
1565 parseJSON _ = fail "NetworkSettings is not an object."
1444
1566
1567+#if MIN_VERSION_base(4,13,0)
1568+parseIntegerText :: (MonadFail m) => Text -> m Integer
1569+#else
1445parseIntegerText :: (Monad m) => Text -> m Integer
1570parseIntegerText :: (Monad m) => Text -> m Integer
1571+#endif
1446parseIntegerText t = case readMaybe $ T.unpack t of
1572parseIntegerText t = case readMaybe $ T.unpack t of
1447 Nothing ->
1573 Nothing ->
1448 fail "Could not parse Integer"
1574 fail "Could not parse Integer"
@@ -1464,4 +1590,3 @@ toJsonKeyVal vs getKey getVal = JSON.Object $ foldl f HM.empty vs
1464-- | Helper function that return an empty dictionary "{}"
1590-- | Helper function that return an empty dictionary "{}"
1465emptyJsonObject :: JSON.Value
1591emptyJsonObject :: JSON.Value
1466emptyJsonObject = JSON.Object HM.empty
1592emptyJsonObject = JSON.Object HM.empty
1467−
stack-7.10.yaml+5−5
@@ -1,20 +1,20 @@
1# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
1# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
2
2
3# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
3# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
4−resolver: lts-5.18
4+resolver: lts-6.30
5
5
6# Local packages, usually specified by relative directory name
6# Local packages, usually specified by relative directory name
7packages:
7packages:
8- '.'
8- '.'
9
9
10−# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
11−extra-deps: [directory-1.2.7.0]
12−
13# Override default flag values for local packages and extra-deps
10# Override default flag values for local packages and extra-deps
14flags: {}
11flags: {}
15
12
16# Extra package databases containing global packages
13# Extra package databases containing global packages
17−extra-package-dbs: []
14+extra-deps:
15+- directory-1.2.7.0
16+- unliftio-core-0.1.1.0
17+- process-1.6.5.1
18
18
19# Control whether we use the GHC we find on the path
19# Control whether we use the GHC we find on the path
20# system-ghc: true
20# system-ghc: true
stack-8.0.2.yamlnew file+4
@@ -0,0 +1,4 @@
1+resolver: lts-9.4
2+packages:
3+- '.'
4+extra-deps: []
stack-8.0.yaml+2−1
@@ -1,4 +1,5 @@
1resolver: lts-7.12
1resolver: lts-7.12
2packages:
2packages:
3- '.'
3- '.'
4−extra-deps: []
4+extra-deps:
5+- unliftio-core-0.1.1.0
stack-8.6.4.yamlnew file+4
@@ -0,0 +1,4 @@
1+resolver: lts-13.19
2+packages:
3+- '.'
4+extra-deps: []
stack-8.8.2.yamlnew file+5
@@ -0,0 +1,5 @@
1+resolver: lts-15.0
2+packages:
3+- '.'
4+extra-deps: []
5+
stack.yaml+1−1
@@ -1 +1 @@
1−stack-7.10.yaml
1+stack-8.6.4.yaml
tests/Dockerfile+1−1
@@ -1,4 +1,4 @@
1FROM debian:jessie
1FROM debian:jessie
2
2
3−CMD ["/bin/bash", "-c", "echo 123"]
3+CMD ["/bin/bash", "-c", "echo $TEST"]
4
4
tests/tests.hs+231−80
@@ -2,6 +2,8 @@
2
2
3module Main where
3module Main where
4
4
5+import Data.Either (rights)
6+import Prelude hiding (all)
5import qualified Test.QuickCheck.Monadic as QCM
7import qualified Test.QuickCheck.Monadic as QCM
6import Test.Tasty
8import Test.Tasty
7import Test.Tasty.HUnit
9import Test.Tasty.HUnit
@@ -9,135 +11,284 @@ import Test.Tasty.QuickCheck (testProperty)
9
11
10import Control.Concurrent (threadDelay)
12import Control.Concurrent (threadDelay)
11import Control.Lens ((^.), (^?))
13import Control.Lens ((^.), (^?))
14+import Control.Monad (forM_)
12import Control.Monad.IO.Class
15import Control.Monad.IO.Class
13import Control.Monad.Trans.Class (lift)
16import Control.Monad.Trans.Class (lift)
14import qualified Data.Aeson as JSON
17import qualified Data.Aeson as JSON
15−import Data.Aeson.Lens (key, _Object, _String, _Value)
18+import Data.Aeson ((.=))
19+import Data.Aeson.Lens (key, _Array, _Null, _Object,
20+ _String, _Value)
16import qualified Data.ByteString as B
21import qualified Data.ByteString as B
17import qualified Data.ByteString.Char8 as C
22import qualified Data.ByteString.Char8 as C
18import qualified Data.ByteString.Lazy as BL
23import qualified Data.ByteString.Lazy as BL
19import qualified Data.HashMap.Strict as HM
24import qualified Data.HashMap.Strict as HM
20import Data.Int (Int)
25import Data.Int (Int)
21import qualified Data.Map as M
26import qualified Data.Map as M
22−import Data.Maybe (fromJust, isJust)
27+import Data.Maybe (fromJust, isJust, isNothing, listToMaybe)
23import Data.Monoid
28import Data.Monoid
24import Data.Text (Text, unpack)
29import Data.Text (Text, unpack)
30+import qualified Data.Vector as V
25import Network.Connection (TLSSettings (..))
31import Network.Connection (TLSSettings (..))
26import Network.HTTP.Client (newManager)
32import Network.HTTP.Client (newManager)
27import Network.HTTP.Client.TLS
33import Network.HTTP.Client.TLS
28import Network.HTTP.Types.Status
34import Network.HTTP.Types.Status
35+import System.Directory (getCurrentDirectory)
36+import System.Environment (lookupEnv)
29import System.Process (system)
37import System.Process (system)
30
38
31import Docker.Client
39import Docker.Client
32
40
33-- opts = defaultClientOpts
41-- opts = defaultClientOpts
34−
35−testImageName = "docker-hs-test"
42+testImageName = "docker-hs/test"
43+imageToDeleteFullName = "hello-world:latest"
36
44
37toStrict1 = B.concat . BL.toChunks
45toStrict1 = B.concat . BL.toChunks
38
46
39−runDocker f = do
47+runDocker f
40− -- let opts = defaultClientOpts {baseUrl = "https://127.0.0.1:2376/"}
48+ -- let opts = defaultClientOpts {baseUrl = "https://127.0.0.1:2376/"}
41− -- params' <- clientParamsWithClientAuthentication "127.0.0.1" 2376 "~/.docker/test-client-key.pem" "~/.docker/test-client-cert.pem" >>= fromRight
49+ -- params' <- clientParamsWithClientAuthentication "127.0.0.1" 2376 "~/.docker/test-client-key.pem" "~/.docker/test-client-cert.pem" >>= fromRight
42− -- params <- clientParamsSetCA params' "~/.docker/test-ca.pem"
50+ -- params <- clientParamsSetCA params' "~/.docker/test-ca.pem"
43− -- let settings = mkManagerSettings (TLSSettings params) Nothing
51+ -- let settings = mkManagerSettings (TLSSettings params) Nothing
44− -- mgr <- newManager settings
52+ -- mgr <- newManager settings
53+ = do
45− h <- defaultHttpHandler
54+ h <- defaultHttpHandler
46− runDockerT (defaultClientOpts, h) f
55+ runDockerT (defaultClientOpts, h) f
47
56
48testDockerVersion :: IO ()
57testDockerVersion :: IO ()
49−testDockerVersion = runDocker $ do
58+testDockerVersion =
59+ runDocker $
50− v <- getDockerVersion
60+ do v <- getDockerVersion
51− lift $ assert $ isRight v
61+ lift $ assert $ isRight v
62+
63+testStopNonexisting :: IO ()
64+testStopNonexisting = runDocker $ do
65+ res <- stopContainer DefaultTimeout $ fromJust $ toContainerID "thisshouldnotexist"
66+ lift $ assert $ isLeft res
52
67
53testFindImage :: IO ()
68testFindImage :: IO ()
54−testFindImage = runDocker $ do
69+testFindImage =
70+ runDocker $
71+ do images <- listImages defaultListOpts >>= fromRight
72+ let xs = filter (elem imageFullName . imageRepoTags) images
73+ lift $ assert $ length xs == 1
74+ where
75+ imageFullName = testImageName <> ":latest"
76+
77+testDeleteImage :: IO ()
78+testDeleteImage = runDocker $ do
79+ img <- fmap fromJust 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
55 images <- listImages defaultListOpts >>= fromRight
87 images <- listImages defaultListOpts >>= fromRight
88+ return $ listToMaybe
56− let xs = filter ((== [imageFullName]) . imageRepoTags) images
89+ $ filter (elem imageToDeleteFullName . imageRepoTags) images
57− lift $ assert $ length xs == 1
90+
58− where imageFullName = testImageName <> ":latest"
91+testListContainers :: IO ()
92+testListContainers =
93+ runDocker $
94+ do containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing
95+ c <- fromRight containerId
96+ res <- listContainers $ ListOpts { all=True }
97+ deleteContainer (ContainerDeleteOpts True True) c
98+ lift $ assert $ isRight res
99+
100+testBuildFromDockerfile :: IO ()
101+testBuildFromDockerfile = do
102+ cur <- getCurrentDirectory
103+ let ctxDir = cur ++ "/tests"
104+ runDocker $ do
105+ r <- buildImageFromDockerfile (defaultBuildOpts "docker-hs/dockerfile-test") ctxDir
106+ lift $ assert $ isRight r
107+
59
108
60testRunAndReadLog :: IO ()
109testRunAndReadLog :: IO ()
110+testRunAndReadLog = testRunAndReadLogHelper $ NetworkingConfig HM.empty
111+
112+testRunAndReadLogWithNetworking :: IO ()
113+testRunAndReadLogWithNetworking = testRunAndReadLogHelper $ NetworkingConfig $ HM.fromList [("test-network", EndpointConfig ["cellar-door"])]
114+
115+testRunAndReadLogHelper :: NetworkingConfig -> IO ()
116+testRunAndReadLogHelper networkingConfig =
61−testRunAndReadLog = runDocker $ do
117+ runDocker $
62− containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing
118+ do let containerConfig = (defaultContainerConfig (testImageName <> ":latest")) {env = [EnvVar "TEST" "123"]}
119+ createdNetworks <- rights <$> mapM createNetworkWithName networkNames
120+ containerId <- createContainer (CreateOpts containerConfig defaultHostConfig networkingConfig) Nothing
63− c <- fromRight containerId
121+ c <- fromRight containerId
64− status1 <- startContainer defaultStartOpts c
122+ status1 <- startContainer defaultStartOpts c
65− _ <- inspectContainer c >>= fromRight
123+ _ <- inspectContainer c >>= fromRight
66− lift $ threadDelay 300000 -- give 300ms for the application to finish
124+ lift $ threadDelay 300000 -- give 300ms for the application to finish
67− lift $ assert $ isRightUnit status1
125+ lift $ assertBool ("starting the container, unexpected status: " ++ show status1) $ isRightUnit status1
68− status2 <- killContainer SIGTERM c
69− logs <- getContainerLogs defaultLogOpts c >>= fromRight
126+ logs <- getContainerLogs defaultLogOpts c >>= fromRight
70− lift $ assert $ isRightUnit status2
71− lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
127+ lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
72− status3 <- deleteContainer (DeleteOpts True True) c
128+ status3 <- deleteContainer (ContainerDeleteOpts True True) c
73− lift $ assert $ isRightUnit status3
129+ lift $ assertBool ("deleting container, unexpected status: " ++ show status3) $ isRightUnit status3
74−
130+ mapM_ removeNetwork createdNetworks
75− where
131+ where
76− isRightUnit (Right ()) = True
132+ isRightUnit (Right ()) = True
77− isRightUnit _ = False
133+ isRightUnit _ = False
134+ networkNames = HM.keys $ endpointsConfig networkingConfig
135+ createNetworkWithName name = createNetwork $
136+ (defaultCreateNetworkOpts name) { createNetworkCheckDuplicate = True }
137+
138+testCreateRemoveNetwork :: IO ()
139+testCreateRemoveNetwork = do
140+ runDocker $ do
141+ createStatus <- createNetwork $ defaultCreateNetworkOpts "test-network"
142+ lift $ assertBool ("creating a network, unexpected status: " ++ show createStatus) $ isRight createStatus
143+ nid <- fromRight createStatus
144+ removeStatus <- removeNetwork nid
145+ lift $ assertBool ("removing a network, unexpected status: " ++ show removeStatus) $ isRight removeStatus
78
146
79testLogDriverOptionsJson :: TestTree
147testLogDriverOptionsJson :: TestTree
80−testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [ test1, test2, test3 ]
148+testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [test1, test2, test3]
81− where
149+ where
82− test1 = testCase "Driver option 1" $ assert $ JSON.toJSON sample ^. key key1 . _String == val1
150+ test1 = testCase "Driver option 1" $ assert $ JSON.toJSON sample ^. key key1 . _String == val1
83− test2 = testCase "Driver option 2" $ assert $ JSON.toJSON sample ^. key key2 . _String == val2
151+ test2 = testCase "Driver option 2" $ assert $ JSON.toJSON sample ^. key key2 . _String == val2
152+ test3 =
84− test3 = testCase "Test override" $ assert $ JSON.toJSON sample2 ^. key key1 . _String == "override"
153+ testCase "Test override" $ assert $ JSON.toJSON sample2 ^. key key1 . _String == "override"
85− sample = [LogDriverOption key1 val1, LogDriverOption key2 val2]
154+ sample = [LogDriverOption key1 val1, LogDriverOption key2 val2]
86− sample2 = [LogDriverOption key1 val1, LogDriverOption key1 "override"]
155+ sample2 = [LogDriverOption key1 val1, LogDriverOption key1 "override"]
87− key1 = "some-key"
156+ key1 = "some-key"
88− val1 = "some-val"
157+ val1 = "some-val"
89− key2 = "some-key2"
158+ key2 = "some-key2"
90− val2 = "some-key2"
159+ val2 = "some-key2"
91
160
92testExposedPortsJson :: TestTree
161testExposedPortsJson :: TestTree
93−testExposedPortsJson = testGroup "Testing ExposedPorts JSON" [ testTCP, testUDP ]
162+testExposedPortsJson = testGroup "Testing ExposedPorts JSON" [testTCP, testUDP]
94− where
163+ where
95− testTCP = testCase "tcp port" $ assert $ JSON.toJSON sampleEP ^. key "80/tcp" . _Object == HM.empty
164+ testTCP = testCase "tcp port" $ assert $ JSON.toJSON sampleEP ^. key "80/tcp" . _Object == HM.empty
165+ testUDP =
96− testUDP = testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty
166+ testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty
97− sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP]
167+ sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP]
98
168
99testLabelsJson :: TestTree
169testLabelsJson :: TestTree
100−testLabelsJson = testGroup "Testing Labels JSON" [ testLS1, testLS2, testOverride ]
170+testLabelsJson = testGroup "Testing Labels JSON" [testLS1, testLS2, testOverride]
101− where
171+ where
102− testLS1 = testCase "test label key1" $ assert $ JSON.toJSON sampleLS ^. key key1 . _String == val1
172+ testLS1 = testCase "test label key1" $ assert $ JSON.toJSON sampleLS ^. key key1 . _String == val1
103− testLS2 = testCase "test label key2" $ assert $ JSON.toJSON sampleLS ^. key key2 . _String == val2
173+ testLS2 = testCase "test label key2" $ assert $ JSON.toJSON sampleLS ^. key key2 . _String == val2
174+ testOverride =
104− testOverride = testCase "test label override" $ assert $ JSON.toJSON [Label key1 val1, Label key1 "override"] ^. key key1 . _String == "override"
175+ testCase "test label override" $ assert $ JSON.toJSON [Label key1 val1, Label key1 "override"] ^.
176+ key key1 .
177+ _String ==
178+ "override"
105− sampleLS = [Label key1 val1, Label key2 val2]
179+ sampleLS = [Label key1 val1, Label key2 val2]
106− key1 = "com.example.some-label"
180+ key1 = "com.example.some-label"
107− val1 = "some-value"
181+ val1 = "some-value"
108− key2 = "something"
182+ key2 = "something"
109− val2 = "value"
183+ val2 = "value"
110
184
111testVolumesJson :: TestTree
185testVolumesJson :: TestTree
112−testVolumesJson = testGroup "Testing Volumes JSON" [ testSample1, testSample2 ]
186+testVolumesJson = testGroup "Testing Volumes JSON" [testSample1, testSample2]
113− where
187+ where
188+ testSample1 =
114− testSample1 = testCase "Test exposing volume: /tmp" $ assert $ JSON.toJSON sampleVolumes ^. key "/tmp" . _Object == HM.empty
189+ testCase "Test exposing volume: /tmp" $ assert $ JSON.toJSON sampleVolumes ^. key "/tmp" . _Object ==
190+ HM.empty
191+ testSample2 =
115− testSample2 = testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON sampleVolumes ^. key "/opt" . _Object == HM.empty
192+ testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON sampleVolumes ^. key "/opt" . _Object ==
193+ HM.empty
116− sampleVolumes = [Volume "/tmp", Volume "/opt"]
194+ sampleVolumes = [Volume "/tmp", Volume "/opt"]
195+
196+testEntrypointJson :: TestTree
197+testEntrypointJson = testGroup "Testing ContainerConfig JSON" [testSample1, testSample2, testSample3, testSample4, testSample5]
198+ where
199+ testSample1 =
200+ testCase "Test toJSON with empty entrypoint (null)" $ assert $ JSON.toJSON (Entrypoint []) ^. _Null == ()
201+ testSample2 =
202+ testCase "Test toJSON with entrypoint as Array" $ assert $
203+ JSON.toJSON (Entrypoint sampleEntrypointArr) ==
204+ JSON.toJSON sampleEntrypointArr
205+ testSample3 =
206+ testCase "Test decoding entrypoint as string" $ assert $ (JSON.decode "\"cmd\"") ==
207+ Just (Entrypoint ["cmd"])
208+ testSample4 =
209+ testCase "Test decoding as null" $ assert $ (JSON.decode "null" :: Maybe Entrypoint) ==
210+ Just (Entrypoint [])
211+ testSample5 =
212+ testCase "Test decoding as array" $ assert $ (JSON.decode (JSON.encode sampleEntrypointArr) :: Maybe Entrypoint) ==
213+ Just (Entrypoint sampleEntrypointArr)
214+ sampleEntrypointArr = ["cmd", "--some-flag", "--some-flag2"]
215+
216+testEnvVarJson :: TestTree
217+testEnvVarJson = testGroup "Testing EnvVar JSON" [testSampleEncode, testSampleDecode]
218+ where
219+ testSampleEncode =
220+ testCase "Test toJSON" $ assert $ JSON.toJSON (EnvVar "cellar" "door") == JSON.String "cellar=door"
221+ testSampleDecode =
222+ testCase "Test fromJSON" $ assert $ (JSON.decode "\"cellar=door\"" :: Maybe EnvVar) ==
223+ Just (EnvVar "cellar" "door")
224+
225+testNetworkingConfigJson :: TestTree
226+testNetworkingConfigJson = testGroup "Testing NetworkingConfig JSON" [testSampleEncode]
227+ where
228+ testSampleEncode =
229+ let networkingConfig = NetworkingConfig $ HM.fromList [("custom-network", EndpointConfig ["cellar", "door"])]
230+ in testCase "Test toJSON" $ assert $ JSON.toJSON networkingConfig ==
231+ JSON.object
232+ [ "EndpointsConfig" .= JSON.object
233+ [ "custom-network" .= JSON.object
234+ [ "Aliases" .= (["cellar", "door"] :: [Text])
235+ ]
236+ ]
237+ ]
117
238
118integrationTests :: TestTree
239integrationTests :: TestTree
119−integrationTests = testGroup "Integration Tests" [
240+integrationTests =
241+ testGroup
242+ "Integration Tests"
120− testCase "Get docker version" testDockerVersion,
243+ [ testCase "Get docker version" testDockerVersion
244+ , testCase "Build image from Dockerfile" testBuildFromDockerfile
121− testCase "Find image by name" testFindImage,
245+ , testCase "Find image by name" testFindImage
246+ , testCase "Delete image" testDeleteImage
247+ , testCase "List containers" testListContainers
122− testCase "Run a dummy container and read its log" testRunAndReadLog]
248+ , testCase "Run a dummy container and read its log" testRunAndReadLog
249+ , testCase "Run a dummy container with networking and read its log" testRunAndReadLogWithNetworking
250+ , testCase "Try to stop a container that doesn't exist" testStopNonexisting
251+ , testCase "Create and remove a network" testCreateRemoveNetwork
252+ ]
123
253
124jsonTests :: TestTree
254jsonTests :: TestTree
125−jsonTests = testGroup "JSON Tests" [testExposedPortsJson, testVolumesJson, testLabelsJson, testLogDriverOptionsJson]
255+jsonTests =
256+ testGroup
257+ "JSON Tests"
258+ [ testExposedPortsJson
259+ , testVolumesJson
260+ , testLabelsJson
261+ , testLogDriverOptionsJson
262+ , testEntrypointJson
263+ , testEnvVarJson
264+ , testNetworkingConfigJson
265+ ]
126
266
127setup :: IO ()
267setup :: IO ()
268+setup =
269+ mapM_ system
270+ [ "docker pull " ++ unpack imageToDeleteFullName
128−setup = system ("docker build -t "++unpack testImageName++" tests") >> return ()
271+ , "docker build -t " ++ unpack testImageName ++ " tests"
272+ ]
273+
274+isLeft = not . isRight
129
275
130−isRight (Left _) = False
276+isRight (Left _) = False
131isRight (Right _) = True
277isRight (Right _) = True
132
278
279+fromRight
133−fromRight :: (MonadIO m, Show l) => Either l r -> m r
280+ :: (MonadIO m, Show l)
281+ => Either l r -> m r
134fromRight (Left l) = do
282fromRight (Left l) = do
135− liftIO $ assertFailure $ "Left: " ++ show l
283+ liftIO $ assertFailure $ "Left: " ++ show l
136− undefined
284+ undefined
137fromRight (Right r) = return r
285fromRight (Right r) = return r
138
286
139main :: IO ()
287main :: IO ()
140main = do
288main = do
289+ stackage <- lookupEnv "RUN_INTEGRATION_TESTS"
290+ case stackage of
291+ Nothing -> defaultMain $ testGroup "Tests" [jsonTests]
292+ Just _ -> do
141− setup
293+ setup
142− defaultMain $ testGroup "Tests" [jsonTests, integrationTests]
294+ defaultMain $ testGroup "Tests" [jsonTests, integrationTests]
143−