on master help sign in
.gitignore+2
since splitsnapshots
unifiedsplit
@@ -3,3 +3,5 @@
3/dist/
3/dist/
4*~
4*~
5.stack-work/
5.stack-work/
6+dist-newstyle
7+/cabal.project.local
.travis.yml+40−7
@@ -1,6 +1,12 @@
1sudo: required
1sudo: required
2dist: trusty
2dist: trusty
3
3
4+# Only build master and release tags
5+branches:
6+ only:
7+ - master
8+ - /^v\d+\.\d+(\.\d+)?(-\S*)?$/
9+
4# Choose a lightweight base image; we provide our own build tools.
10# Choose a lightweight base image; we provide our own build tools.
5language:
11language:
6 c
12 c
@@ -16,7 +22,30 @@ services:
16 - docker
22 - docker
17
23
18env:
24env:
25+ global:
26+ - RUN_INTEGRATION_TESTS=1
19− - STACK_ARGS=""
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
20
49
21addons:
50addons:
22 apt:
51 apt:
@@ -24,20 +53,24 @@ addons:
24 - libgmp-dev
53 - libgmp-dev
25
54
26before_install:
55before_install:
27− # Upgrade docker to 1.12
56+ # Upgrade docker to 1.12.3.0
28 - 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'
29 - 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
30 - sudo apt-get update
59 - sudo apt-get update
31− - sudo apt-get -qqy -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confold" install docker-engine=1.12.0-0~trusty
60+ - sudo apt-get -qqy -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confold" install docker-engine=$DOCKER_VERSION
61+
62+install:
32 - mkdir -p "$HOME"/.local/bin
63 - mkdir -p "$HOME"/.local/bin
33 - export PATH=$HOME/.local/bin:$PATH
64 - export PATH=$HOME/.local/bin:$PATH
34−
65+ - export STACK_YAML=stack-$GHCVER.yaml
35 # install Stack
66 # install Stack
36 - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C $HOME/.local/bin '*/stack'
67 - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C $HOME/.local/bin '*/stack'
37− - export PATH=$(stack --stack-yaml stack.yaml path --local-install-root):$PATH
68+ - export PATH=$(stack path --local-install-root):$PATH
38− - stack setup
69+ - stack --version
39−
40
70
41script:
71script:
72+ - stack setup
73+ - stack update
74+ - stack build
42 - stack test
75 - stack test
43
76
CHANGELOG.md+79
@@ -1,5 +1,84 @@
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+
74+## 0.3.0.1 (2016-09-07)
75+
76+- Small cosmetic changes and marking OVERLAPPING instance
77+
78+## 0.3.0.0 (2016-09-06)
79+
80+Major rewrite
81+
3## 0.2.0.4 (2016-02-11)
82## 0.2.0.4 (2016-02-11)
4
83
5- Adds function for getting all containers and images
84- Adds function for getting all containers and images
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+21−2
@@ -1,4 +1,6 @@
1−.PHONY: build repl test release
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,18 +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
22
23+## Cut new release
18release:
24release:
19 @stack build --haddock
25 @stack build --haddock
20 @stack sdist
26 @stack sdist
21 @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"
22 @echo "\nAnd: \n\ngit tag ${VERSION} && git push --tags\n"
28 @echo "\nAnd: \n\ngit tag ${VERSION} && git push --tags\n"
23
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+34−12
@@ -1,26 +1,48 @@
1# An API client for docker written in Haskell
1# An API client for docker written in Haskell
2
2
3−| Master | Dev |
3+| Master |
4−| -------| ---- |
4+| -------|
5−| [![master](https://travis-ci.org/denibertovic/docker-hs.svg?branch=master)](https://travis-ci.org/denibertovic/docker-hs) | [![dev](https://travis-ci.org/denibertovic/docker-hs.svg?branch=dev)](https://travis-ci.org/denibertovic/docker-hs) |
5+| [![master](https://travis-ci.org/denibertovic/docker-hs.svg?branch=master)](https://travis-ci.org/denibertovic/docker-hs) |
6
6
7
7
8## Current state
8## Current state
9
9
10−**Not production ready yet!**
10+Supported Docker Engine Api version: `v1.24` and onwards.
11
11
12−The library is going through a **total rewrite**.
12+Anything upward of that should work since Docker versions their API.
13+Older docker version and engine api versions are not supported at the moment.
13
14
14−See [Issue #12](https://github.com/denibertovic/docker-hs/issues/12) for things
15+## Documentation
15−that need to happen before a new release.
16
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).
17
21
18## Contributing
22## Contributing
19
23
20−If you wish to contribute please see the Issue mentioned above or any issue tagged with "help wanted".
24+Please see [CONTRIBUTING.md](CONTRIBUTING.md).
21−Make sure to submit your PR's against the `dev` branch.
22
25
23−Please consider filling an Issue first and discuss design decisions and implementation details before
26+### Project Setup
24−writing any code. This is so that no development cycles go to waste on implementing a feature that
25−might not get merged either because of implementation details or other reasons.
26
27
28+For working on the library, you need the Haskell Tool Stack installed (see [the
29+Haskell Tool Stack
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).
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`.
44+
45+## IRC
46+
47+If you have any questions or suggestions you can find the maintainers in `#docker-haskell`
48+on freenode.
docker.cabal+44−13
@@ -1,7 +1,7 @@
1name: docker
1name: docker
2−version: 0.3.0.0
2+version: 0.6.0.3
3synopsis: An API client for docker written in Haskell
3synopsis: An API client for docker written in Haskell
4−description: See README.md
4+description: See API documentation below.
5homepage: https://github.com/denibertovic/docker-hs
5homepage: https://github.com/denibertovic/docker-hs
6license: BSD3
6license: BSD3
7license-file: LICENSE
7license-file: LICENSE
@@ -14,28 +14,57 @@ 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
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.6.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
36+ , conduit
37+ , conduit-combinators
38+ , conduit-extra
39+ , exceptions
40+ , monad-control
41+ , resourcet
42+ , transformers
43+ , transformers-base
44+ , tar
45+ , zlib
46+ , uuid
47+ , temporary
48+ , directory >= 1.2.5.0
49+ , filemanip
50+ , filepath
30 , mtl >= 2.0.0 && < 3.0.0
51 , mtl >= 2.0.0 && < 3.0.0
31 , network >= 2.6.0
52 , network >= 2.6.0
32 , text >= 1.0.0 && < 2.0.0
53 , text >= 1.0.0 && < 2.0.0
33− , time >= 1.5.0 && < 1.7.0
54+ , time >= 1.5.0 && < 2.0.0
55+ , scientific >= 0.3.0 && < 0.4.0
34− , tls >= 1.3.7 && < 1.4.0
56+ , tls >= 1.3.7 && < 1.6.0
35 , unordered-containers >= 0.2.0 && < 0.3.0
57 , unordered-containers >= 0.2.0 && < 0.3.0
36− , x509 >= 1.6.0 && < 1.7.0
58+ , x509 >= 1.6.0 && < 1.8.0
37− , x509-store >= 1.6.0 && < 1.7.0
59+ , x509-store >= 1.6.0 && < 1.8.0
38− , 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
39 default-language: Haskell2010
68 default-language: Haskell2010
40 ghc-options: -Wall -fno-warn-name-shadowing
69 ghc-options: -Wall -fno-warn-name-shadowing
41
70
@@ -44,6 +73,7 @@ test-suite docker-hs-tests
44 , bytestring
73 , bytestring
45 , connection
74 , connection
46 , docker
75 , docker
76+ , directory
47 , aeson
77 , aeson
48 , containers
78 , containers
49 , unordered-containers
79 , unordered-containers
@@ -59,6 +89,7 @@ test-suite docker-hs-tests
59 , transformers
89 , transformers
60 , QuickCheck
90 , QuickCheck
61 , process
91 , process
92+ , vector
62 type: exitcode-stdio-1.0
93 type: exitcode-stdio-1.0
63 main-is: tests.hs
94 main-is: tests.hs
64 hs-source-dirs: tests
95 hs-source-dirs: tests
examples/Example.hs+52−43
@@ -1,55 +1,64 @@
1import Docker.Client
1import Docker.Client
2
2
3runNginxContainer :: IO ContainerID
3runNginxContainer :: IO ContainerID
4+runNginxContainer = do
5+ h <- defaultHttpHandler
4−runNginxContainer = runDockerT (defaultClientOpts, defaultHttpHandler) $ do
6+ runDockerT (defaultClientOpts, h) $
5− let pb = PortBinding 80 TCP [HostPort "0.0.0.0" 8000]
7+ do let pb = PortBinding 80 TCP [HostPort "0.0.0.0" 8000]
6− let myCreateOpts = addPortBinding pb $ defaultCreateOpts "nginx:latest"
8+ let myCreateOpts = addPortBinding pb $ defaultCreateOpts "nginx:latest"
7− cid <- createContainer myCreateOpts (Just "myNginxContainer")
9+ cid <- createContainer myCreateOpts (Just "myNginxContainer")
8− case cid of
10+ case cid of
9− Left err -> error $ show err
11+ Left err -> error $ show err
10− Right i -> do
12+ Right i -> do
11− _ <- startContainer defaultStartOpts i
13+ _ <- startContainer defaultStartOpts i
12− return i
14+ return i
13
15
14stopNginxContainer :: ContainerID -> IO ()
16stopNginxContainer :: ContainerID -> IO ()
17+stopNginxContainer cid = do
18+ h <- defaultHttpHandler
15−stopNginxContainer cid = runDockerT (defaultClientOpts, defaultHttpHandler) $ do
19+ runDockerT (defaultClientOpts, h) $
16− r <- stopContainer DefaultTimeout cid
20+ do r <- stopContainer DefaultTimeout cid
17− case r of
21+ case r of
18− Left _ -> error "I failed to stop the container"
22+ Left _ -> error "I failed to stop the container"
19− Right _ -> return ()
23+ Right _ -> return ()
20
24
21runPostgresContainer :: IO ContainerID
25runPostgresContainer :: IO ContainerID
26+runPostgresContainer = do
27+ h <- defaultHttpHandler
22−runPostgresContainer = runDockerT (defaultClientOpts, defaultHttpHandler) $ do
28+ runDockerT (defaultClientOpts, h) $
23− let pb = PortBinding 5432 TCP [HostPort "0.0.0.0" 5432]
29+ do let pb = PortBinding 5432 TCP [HostPort "0.0.0.0" 5432]
24− let b = Bind "/tmp" "/tmp" Nothing
30+ let b = Bind "/tmp" "/tmp" Nothing
25− let myCreateOpts = addBind b $ addPortBinding pb $ defaultCreateOpts "postgres:9.5"
31+ let myCreateOpts = addBind b $ addPortBinding pb $ defaultCreateOpts "postgres:9.5"
26− cid <- createContainer myCreateOpts Nothing
32+ cid <- createContainer myCreateOpts Nothing
27− case cid of
33+ case cid of
28− Left err -> error $ show err
34+ Left err -> error $ show err
29− Right i -> do
35+ Right i -> do
30− _ <- startContainer defaultStartOpts i
36+ _ <- startContainer defaultStartOpts i
31− return i
37+ return i
32
38
33-- | Example of how we can start a database container while hosting it's
39-- | Example of how we can start a database container while hosting it's
34-- data in a data volume living inside another container.
40-- data in a data volume living inside another container.
35runPostgresWithDataContainer :: IO ContainerID
41runPostgresWithDataContainer :: IO ContainerID
36−runPostgresWithDataContainer = runDockerT (defaultClientOpts, defaultHttpHandler) $ do
42+runPostgresWithDataContainer = do
43+ h <- defaultHttpHandler
44+ runDockerT (defaultClientOpts, h) $
37− -- We use a dummy command like /bin/true because we don't want to start
45+ -- We use a dummy command like /bin/true because we don't want to start
38− -- the postgres database in the data container we just want it to
46+ -- the postgres database in the data container we just want it to
39− -- create a container filesystem for us.
47+ -- create a container filesystem for us.
40− let dataOpts = setCmd "/bin/true" $ defaultCreateOpts "postgres:9.5"
48+ do let dataOpts = setCmd "/bin/true" $ defaultCreateOpts "postgres:9.5"
41− cid <- createContainer dataOpts (Just "myDataContainer")
49+ cid <- createContainer dataOpts (Just "myDataContainer")
50+ _ <-
42− _ <- case cid of
51+ case cid of
43− Left err -> error $ show err
52+ Left err -> error $ show err
44− Right i -> startContainer defaultStartOpts i
53+ Right i -> startContainer defaultStartOpts i
45− let pb = PortBinding 5432 TCP [HostPort "0.0.0.0" 5432]
54+ let pb = PortBinding 5432 TCP [HostPort "0.0.0.0" 5432]
46− -- Default permission is read-write if we don't specify anything
55+ -- Default permission is read-write if we don't specify anything
47− let vf = VolumeFrom "myDataContainer" Nothing
56+ let vf = VolumeFrom "myDataContainer" Nothing
48− let myCreateOpts = addVolumeFrom vf $ addPortBinding pb $ defaultCreateOpts "postgres:9.5"
57+ let myCreateOpts = addVolumeFrom vf $ addPortBinding pb $ defaultCreateOpts "postgres:9.5"
49− ccid <- createContainer myCreateOpts (Just "pgContainer")
58+ ccid <- createContainer myCreateOpts (Just "pgContainer")
50− case ccid of
59+ case ccid of
51− Left err -> error $ show err
60+ Left err -> error $ show err
52− Right i -> do
61+ Right i -> do
53− _ <- startContainer defaultStartOpts i
62+ _ <- startContainer defaultStartOpts i
54− return i
63+ return i
55
64
scripts/hackage-docs.shnew file+22
@@ -0,0 +1,22 @@
1+#!/bin/bash
2+
3+# Run this script in the top-level of your package directory
4+# (where the .cabal file is) to compile documentation and
5+# upload it to hackage.
6+
7+# Requirements:
8+# cabal-install-1.24 (for --for-hackage)
9+# haddock 2.17 (for the hyperlinked source)
10+
11+set -e
12+
13+VERSION=`grep "^version:" docker.cabal | cut -d " " -f14`
14+BUILDDIR=dist-newstyle/build/docker-$VERSION
15+DOCSDIRNAME=docker-$VERSION-docs
16+
17+cabal act-as-setup -- haddock --builddir=$BUILDDIR --for-hackage --hyperlink-sources
18+cd $BUILDDIR/doc/html && tar --format=ustar -zcvf $DOCSDIRNAME.tar.gz $DOCSDIRNAME
19+
20+echo NOW RUN: \n\n
21+echo cabal upload -d $BUILDDIR/doc/html/$DOCSDIRNAME.tar.gz
22+
src/Docker/Client.hs+12−5
@@ -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
@@ -20,7 +20,9 @@ the host.
20import Docker.Client
20import Docker.Client
21
21
22runNginxContainer :: IO ContainerID
22runNginxContainer :: IO ContainerID
23+runNginxContainer = do
24+ h <- defaultHttpHandler
23−runNginxContainer = runDockerT (defaultClientOpts, defaultHttpHandler) $ do
25+ runDockerT (defaultClientOpts, h) $ do
24 let pb = PortBinding 80 TCP [HostPort "0.0.0.0" 8000]
26 let pb = PortBinding 80 TCP [HostPort "0.0.0.0" 8000]
25 let myCreateOpts = addPortBinding pb $ defaultCreateOpts "nginx:latest"
27 let myCreateOpts = addPortBinding pb $ defaultCreateOpts "nginx:latest"
26 cid <- createContainer myCreateOpts
28 cid <- createContainer myCreateOpts
@@ -42,7 +44,9 @@ Let's stop the container now:
42
44
43@
45@
44stopNginxContainer :: ContainerID -> IO ()
46stopNginxContainer :: ContainerID -> IO ()
47+stopNginxContainer cid = do
48+ h <- defaultHttpHandler
45−stopNginxContainer cid = runDockerT (defaultClientOpts, defaultHttpHandler) $ do
49+ runDockerT (defaultClientOpts, h) $ do
46 r <- stopContainer DefaultTimeout cid
50 r <- stopContainer DefaultTimeout cid
47 case r of
51 case r of
48 Left err -> error "I failed to stop the container"
52 Left err -> error "I failed to stop the container"
@@ -57,7 +61,9 @@ persist on the host file system.
57
61
58@
62@
59runPostgresContainer :: IO ContainerID
63runPostgresContainer :: IO ContainerID
64+runPostgresContainer = do
65+ h <- defaultHttpHandler
60−runPostgresContainer = runDockerT (defaultClientOpts, defaultHttpHandler) $ do
66+ runDockerT (defaultClientOpts, h) $ do
61 let pb = PortBinding 5432 TCP [HostPort "0.0.0.0" 5432]
67 let pb = PortBinding 5432 TCP [HostPort "0.0.0.0" 5432]
62 let myCreateOpts = addBinds [Bind "\/tmp" "\/tmp" Nothing] $ addPortBinding pb $ defaultCreateOpts "postgres:9.5"
68 let myCreateOpts = addBinds [Bind "\/tmp" "\/tmp" Nothing] $ addPortBinding pb $ defaultCreateOpts "postgres:9.5"
63 cid <- createContainer myCreateOpts
69 cid <- createContainer myCreateOpts
@@ -70,7 +76,8 @@ runPostgresContainer = runDockerT (defaultClientOpts, defaultHttpHandler) $ do
70
76
71= Get Docker API Version
77= Get Docker API Version
72
78
79+>>> h <- defaultHttpHandler
73−>>> runDockerT (defaultClientOpts, defaultHttpHandler) $ getDockerVersion
80+>>> runDockerT (defaultClientOpts, h) $ getDockerVersion
74Right (DockerVersion {version = "1.12.0", apiVersion = "1.24", gitCommit = "8eab29e", goVersion = "go1.6.3", os = "linux", arch = "amd64", kernelVersion = "4.6.0-1-amd64", buildTime = "2016-07-28T21:46:40.664812891+00:00"})
81Right (DockerVersion {version = "1.12.0", apiVersion = "1.24", gitCommit = "8eab29e", goVersion = "go1.6.3", os = "linux", arch = "amd64", kernelVersion = "4.6.0-1-amd64", buildTime = "2016-07-28T21:46:40.664812891+00:00"})
75
82
76= Setup SSL Authentication
83= Setup SSL Authentication
src/Docker/Client/Api.hs+129−48
@@ -7,6 +7,7 @@ module Docker.Client.Api (
7 , createContainer
7 , createContainer
8 , startContainer
8 , startContainer
9 , stopContainer
9 , stopContainer
10+ , waitContainer
10 , killContainer
11 , killContainer
11 , restartContainer
12 , restartContainer
12 , pauseContainer
13 , pauseContainer
@@ -14,110 +15,143 @@ module Docker.Client.Api (
14 , deleteContainer
15 , deleteContainer
15 , inspectContainer
16 , inspectContainer
16 , getContainerLogs
17 , getContainerLogs
18+ , getContainerLogsStream
17 -- * Images
19 -- * Images
18 , listImages
20 , listImages
21+ , deleteImage
22+ , buildImageFromDockerfile
23+ , pullImage
24+ -- * Network
25+ , createNetwork
26+ , removeNetwork
19 -- * Other
27 -- * Other
20 , getDockerVersion
28 , getDockerVersion
21 ) where
29 ) where
22
30
23−import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
31+import Control.Monad.Catch (MonadMask (..))
24−import Control.Monad.Reader (ask, lift)
32+import Control.Monad.IO.Class
33+import Control.Monad.Reader (ask, lift)
25−import Data.Aeson (FromJSON, eitherDecode')
34+import Data.Aeson (FromJSON, eitherDecode')
26−import qualified Data.ByteString.Lazy as BSL
35+import qualified Data.ByteString as BS
36+import qualified Data.ByteString.Lazy as BSL
37+import Data.Conduit (Sink)
38+import qualified Data.Conduit.Binary as Conduit
27−import qualified Data.Text as Text
39+import qualified Data.Text as T
40+import qualified Data.Text as Text
28−import Network.HTTP.Client (responseBody, responseStatus)
41+import Network.HTTP.Client (responseStatus)
29−import Network.HTTP.Types (StdMethod (..))
42+import Network.HTTP.Types (StdMethod (..))
43+import System.Exit (ExitCode (..))
30
44
31import Docker.Client.Http
45import Docker.Client.Http
32import Docker.Client.Types
46import Docker.Client.Types
47+import Docker.Client.Utils
33
48
34−requestUnit :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())
49+requestUnit :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())
35−requestUnit verb endpoint = const (Right ()) <$> requestHelper verb endpoint
50+requestUnit verb endpoint = fmap (const ()) <$> requestHelper verb endpoint
36
51
37−requestHelper :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError Response)
52+requestHelper :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError BSL.ByteString)
38−requestHelper verb endpoint = runExceptT $ do
53+requestHelper verb endpoint = requestHelper' verb endpoint Conduit.sinkLbs
54+
55+requestHelper' :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> Sink BS.ByteString m a -> DockerT m (Either DockerError a)
56+requestHelper' verb endpoint sink = do
39− (opts, httpHandler) <- lift ask
57+ (opts, HttpHandler httpHandler) <- ask
40 case mkHttpRequest verb endpoint opts of
58 case mkHttpRequest verb endpoint opts of
41 Nothing ->
59 Nothing ->
42− throwError $ DockerInvalidRequest endpoint
60+ return $ Left $ DockerInvalidRequest endpoint
43 Just request -> do
61 Just request -> do
62+ -- JP: Do we need runResourceT?
63+ -- lift $ NHS.httpSink request $ \response ->
44− response <- ExceptT $ lift $ httpHandler request
64+ lift $ httpHandler request $ \response ->
45−
46− -- Check status code.
65+ -- Check status code.
47− let status = responseStatus response
66+ let status = responseStatus response in
48− maybe (return ()) throwError $
49− statusCodeToError endpoint status
67+ case statusCodeToError endpoint status of
50−
68+ Just err ->
51− return response
69+ return $ Left err
52−
70+ Nothing ->
71+ fmap Right sink
72+
53−parseResponse :: (FromJSON a, Monad m) => Either DockerError Response -> DockerT m (Either DockerError a)
73+parseResponse :: (FromJSON a, Monad m) => Either DockerError BSL.ByteString -> DockerT m (Either DockerError a)
54parseResponse (Left err) =
74parseResponse (Left err) =
55 return $ Left err
75 return $ Left err
56parseResponse (Right response) =
76parseResponse (Right response) =
57 -- Parse request body.
77 -- Parse request body.
58− case eitherDecode' $ responseBody response of
78+ case eitherDecode' response of
59 Left err ->
79 Left err ->
60 return $ Left $ DockerClientDecodeError $ Text.pack err
80 return $ Left $ DockerClientDecodeError $ Text.pack err
61 Right r ->
81 Right r ->
62 return $ Right r
82 return $ Right r
63
83
64-- | Gets the version of the docker engine remote API.
84-- | Gets the version of the docker engine remote API.
65−getDockerVersion :: forall m. Monad m => DockerT m (Either DockerError DockerVersion)
85+getDockerVersion :: forall m. (MonadIO m, MonadMask m) => DockerT m (Either DockerError DockerVersion)
66getDockerVersion = requestHelper GET VersionEndpoint >>= parseResponse
86getDockerVersion = requestHelper GET VersionEndpoint >>= parseResponse
67
87
68-- | Lists all running docker containers. Pass in @'defaultListOpts' {all
88-- | Lists all running docker containers. Pass in @'defaultListOpts' {all
69-- = True}@ to get a list of stopped containers as well.
89-- = True}@ to get a list of stopped containers as well.
70−listContainers :: forall m. Monad m => ListOpts -> DockerT m (Either DockerError [Container])
90+listContainers :: forall m. (MonadIO m, MonadMask m) => ListOpts -> DockerT m (Either DockerError [Container])
71listContainers opts = requestHelper GET (ListContainersEndpoint opts) >>= parseResponse
91listContainers opts = requestHelper GET (ListContainersEndpoint opts) >>= parseResponse
72
92
73-- | Lists all docker images.
93-- | Lists all docker images.
74−listImages :: forall m. Monad m => ListOpts -> DockerT m (Either DockerError [Image])
94+listImages :: forall m. (MonadIO m, MonadMask m) => ListOpts -> DockerT m (Either DockerError [Image])
75listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse
95listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse
76
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+
77-- | Creates a docker container but does __not__ start it. See
103-- | Creates a docker container but does __not__ start it. See
78-- 'CreateOpts' for a list of options and you can use 'defaultCreateOpts'
104-- 'CreateOpts' for a list of options and you can use 'defaultCreateOpts'
79-- for some sane defaults.
105-- for some sane defaults.
80−createContainer :: forall m. Monad m => CreateOpts -> Maybe ContainerName -> DockerT m (Either DockerError ContainerID)
106+createContainer :: forall m. (MonadIO m, MonadMask m) => CreateOpts -> Maybe ContainerName -> DockerT m (Either DockerError ContainerID)
81createContainer opts cn = requestHelper POST (CreateContainerEndpoint opts cn) >>= parseResponse
107createContainer opts cn = requestHelper POST (CreateContainerEndpoint opts cn) >>= parseResponse
82
108
83-- | Start a container from a given 'ContainerID' that we get from
109-- | Start a container from a given 'ContainerID' that we get from
84-- 'createContainer'. See 'StartOpts' for a list of configuration options
110-- 'createContainer'. See 'StartOpts' for a list of configuration options
85-- for starting a container. Use 'defaultStartOpts' for sane defaults.
111-- for starting a container. Use 'defaultStartOpts' for sane defaults.
86−startContainer :: forall m. Monad m => StartOpts -> ContainerID -> DockerT m (Either DockerError ())
112+startContainer :: forall m. (MonadIO m, MonadMask m) => StartOpts -> ContainerID -> DockerT m (Either DockerError ())
87startContainer sopts cid = requestUnit POST $ StartContainerEndpoint sopts cid
113startContainer sopts cid = requestUnit POST $ StartContainerEndpoint sopts cid
88
114
89-- | Attempts to stop a container with the given 'ContainerID' gracefully
115-- | Attempts to stop a container with the given 'ContainerID' gracefully
90-- (SIGTERM).
116-- (SIGTERM).
91-- The docker daemon will wait for the given 'Timeout' and then send
117-- The docker daemon will wait for the given 'Timeout' and then send
92-- a SIGKILL killing the container.
118-- a SIGKILL killing the container.
93−stopContainer :: forall m. Monad m => Timeout -> ContainerID -> DockerT m (Either DockerError ())
119+stopContainer :: forall m. (MonadIO m, MonadMask m) => Timeout -> ContainerID -> DockerT m (Either DockerError ())
94stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid
120stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid
95
121
122+-- | Blocks until a container with the given 'ContainerID' stops,
123+-- then returns the exit code
124+waitContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ExitCode)
125+waitContainer cid = fmap (fmap statusCodeToExitCode) (requestHelper POST (WaitContainerEndpoint cid) >>= parseResponse)
126+ where
127+ statusCodeToExitCode (StatusCode 0) = ExitSuccess
128+ statusCodeToExitCode (StatusCode x) = ExitFailure x
129+
96-- | Sends a 'Signal' to the container with the given 'ContainerID'. Same
130-- | Sends a 'Signal' to the container with the given 'ContainerID'. Same
97-- as 'stopContainer' but you choose the signal directly.
131-- as 'stopContainer' but you choose the signal directly.
98−killContainer :: forall m. Monad m => Signal -> ContainerID -> DockerT m (Either DockerError ())
132+killContainer :: forall m. (MonadIO m, MonadMask m) => Signal -> ContainerID -> DockerT m (Either DockerError ())
99killContainer s cid = requestUnit POST $ KillContainerEndpoint s cid
133killContainer s cid = requestUnit POST $ KillContainerEndpoint s cid
100
134
101-- | Restarts a container with the given 'ContainerID'.
135-- | Restarts a container with the given 'ContainerID'.
102−restartContainer :: forall m. Monad m => Timeout -> ContainerID -> DockerT m (Either DockerError ())
136+restartContainer :: forall m. (MonadIO m, MonadMask m) => Timeout -> ContainerID -> DockerT m (Either DockerError ())
103restartContainer t cid = requestUnit POST $ RestartContainerEndpoint t cid
137restartContainer t cid = requestUnit POST $ RestartContainerEndpoint t cid
104
138
105-- | Pauses a container with the given 'ContainerID'.
139-- | Pauses a container with the given 'ContainerID'.
106−pauseContainer :: forall m. Monad m => ContainerID -> DockerT m (Either DockerError ())
140+pauseContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ())
107pauseContainer cid = requestUnit POST $ PauseContainerEndpoint cid
141pauseContainer cid = requestUnit POST $ PauseContainerEndpoint cid
108
142
109-- | Unpauses a container with the given 'ContainerID'.
143-- | Unpauses a container with the given 'ContainerID'.
110−unpauseContainer :: forall m. Monad m => ContainerID -> DockerT m (Either DockerError ())
144+unpauseContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ())
111unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid
145unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid
112
146
113-- | Deletes a container with the given 'ContainerID'.
147-- | Deletes a container with the given 'ContainerID'.
114−-- See "DeleteOpts" for options and use 'defaultDeleteOpts' for sane
148+-- See "ContainerDeleteOpts" for options and use 'defaultContainerDeleteOpts' for sane
115-- defaults.
149-- defaults.
116−deleteContainer :: forall m. Monad m => DeleteOpts -> ContainerID -> DockerT m (Either DockerError ())
150+deleteContainer :: forall m. (MonadIO m, MonadMask m) => ContainerDeleteOpts -> ContainerID -> DockerT m (Either DockerError ())
117deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid
151deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid
118
152
119-- | Gets 'ContainerDetails' for a given 'ContainerID'.
153-- | Gets 'ContainerDetails' for a given 'ContainerID'.
120−inspectContainer :: forall m . Monad m => ContainerID -> DockerT m (Either DockerError ContainerDetails)
154+inspectContainer :: forall m . (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ContainerDetails)
121inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= parseResponse
155inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= parseResponse
122
156
123-- | Get's container's logs for a given 'ContainerID'.
157-- | Get's container's logs for a given 'ContainerID'.
@@ -127,20 +161,67 @@ inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= pars
127-- See 'LogOpts' for options that you can pass and
161-- See 'LogOpts' for options that you can pass and
128-- 'defaultLogOpts' for sane defaults.
162-- 'defaultLogOpts' for sane defaults.
129--
163--
130−-- __NOTE__: Currently streaming logs is
131−-- not supported and this function will fetch the entire log that the
164+-- __NOTE__: his function will fetch the entire log that the
132-- container produced in the json-file on disk. Depending on the logging
165-- container produced in the json-file on disk. Depending on the logging
133-- setup of the process in your container this can be a significant amount
166-- setup of the process in your container this can be a significant amount
134-- which might block your application...so use with caution.
167-- which might block your application...so use with caution.
135--
168--
169+-- If you want to stream the logs from the container continuosly then use
170+-- 'getContainerLogsStream'
171+--
136−-- The recommended method is to use one of the other 'LogDriverType's available (like
172+-- __NOTE__: It's recommended to use one of the other 'LogDriverType's available (like
137-- syslog) for creating your containers.
173-- syslog) for creating your containers.
138−getContainerLogs :: forall m. Monad m => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString)
174+getContainerLogs :: forall m. (MonadIO m, MonadMask m) => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString)
139−getContainerLogs logopts cid = fmap responseBody <$> requestHelper GET (ContainerLogsEndpoint logopts False cid)
175+getContainerLogs logopts cid = requestHelper GET (ContainerLogsEndpoint logopts False cid)
140−
176+
141−-- TODO: Use http-conduit to output to a sink.
177+{-| Continuously gets the container's logs as a stream. Uses conduit.
178+
179+__Example__:
180+
181+@
182+>>> import Docker.Client
183+>>> import Data.Maybe
184+>>> import Conduit
185+>>> h <- defaultHttpHanlder
186+>>> let cid = fromJust $ toContainerID "fee86e1d522b"
187+>>> runDockerT (defaultClientOpts, h) $ getContainerLogsStream defaultLogOpts cid stdoutC
188+@
189+
190+-}
142−-- getContainerLogsStream :: forall m. Monad m => Sink BSL.ByteString m b -> LogOpts -> ContainerID -> DockerT m (Either DockerError b)
191+getContainerLogsStream :: forall m b . (MonadIO m, MonadMask m) => LogOpts -> ContainerID -> Sink BS.ByteString m b -> DockerT m (Either DockerError b)
143−-- getContainerLogsStream sink logopts cid = runResourceT $ do
192+getContainerLogsStream logopts cid = requestHelper' GET (ContainerLogsEndpoint logopts True cid)
144−-- response <- http request manager
193+-- JP: Should the second (follow) argument be True? XXX
145−-- responseBody response C.$$+- sink
194+
195+-- | Build an Image from a Dockerfile
196+--
197+-- TODO: Add X-Registry-Config
198+--
199+-- TODO: Add support for remote URLs to a Dockerfile
200+--
201+-- TODO: Clean up temp tar.gz file after the image is built
202+buildImageFromDockerfile :: forall m. (MonadIO m, MonadMask m) => BuildOpts -> FilePath -> DockerT m (Either DockerError ())
203+buildImageFromDockerfile opts base = do
204+ ctx <- makeBuildContext $ BuildContextRootDir base
205+ case ctx of
206+ Left e -> return $ Left e
207+ Right c -> requestUnit POST (BuildImageEndpoint opts c)
208+
209+-- | Pulls an image from Docker Hub (by default).
210+--
211+-- TODO: Add support for X-Registry-Auth and pulling from private docker
212+-- registries.
213+--
214+-- TODO: Implement importImage function that uses he same
215+-- CreateImageEndpoint but rather than pulling from docker hub it imports
216+-- the image from a tarball or a URL.
217+pullImage :: forall m b . (MonadIO m, MonadMask m) => T.Text -> Tag -> Sink BS.ByteString m b -> DockerT m (Either DockerError b)
218+pullImage name tag = requestHelper' POST (CreateImageEndpoint name tag Nothing)
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
146
227
src/Docker/Client/Http.hs+86−29
@@ -3,21 +3,28 @@
3
3
4module Docker.Client.Http where
4module Docker.Client.Http where
5
5
6+-- import Control.Monad.Base (MonadBase(..), liftBaseDefault)
7+import Control.Monad.Catch (MonadMask (..))
8+#if MIN_VERSION_http_conduit(2,3,0)
9+import Control.Monad.IO.Unlift (MonadUnliftIO)
10+#endif
6−import Control.Monad.Reader (ReaderT, runReaderT)
11+import Control.Monad.Reader (ReaderT (..), runReaderT)
7import qualified Data.ByteString.Char8 as BSC
12import qualified Data.ByteString.Char8 as BSC
8import qualified Data.ByteString.Lazy as BL
13import qualified Data.ByteString.Lazy as BL
14+import Data.Conduit (Sink)
9import Data.Default.Class (def)
15import Data.Default.Class (def)
10import Data.Monoid ((<>))
16import Data.Monoid ((<>))
11import Data.Text.Encoding (encodeUtf8)
17import Data.Text.Encoding (encodeUtf8)
12import Data.X509 (CertificateChain (..))
18import Data.X509 (CertificateChain (..))
13import Data.X509.CertificateStore (makeCertificateStore)
19import Data.X509.CertificateStore (makeCertificateStore)
14import Data.X509.File (readKeyFile, readSignedObject)
20import Data.X509.File (readKeyFile, readSignedObject)
15−import Network.HTTP.Client (defaultManagerSettings, httpLbs,
21+import Network.HTTP.Client (defaultManagerSettings,
16 managerRawConnection, method,
22 managerRawConnection, method,
17− newManager, parseUrl,
23+ newManager, parseRequest,
18 requestBody, requestHeaders)
24 requestBody, requestHeaders)
19import qualified Network.HTTP.Client as HTTP
25import qualified Network.HTTP.Client as HTTP
20import Network.HTTP.Client.Internal (makeConnection)
26import Network.HTTP.Client.Internal (makeConnection)
27+import qualified Network.HTTP.Simple as NHS
21import Network.HTTP.Types (StdMethod, status101, status200,
28import Network.HTTP.Types (StdMethod, status101, status200,
22 status201, status204)
29 status201, status204)
23import Network.TLS (ClientHooks (..),
30import Network.TLS (ClientHooks (..),
@@ -27,7 +34,7 @@ import Network.TLS (ClientHooks (..),
27import Network.TLS.Extra (ciphersuite_strong)
34import Network.TLS.Extra (ciphersuite_strong)
28import System.X509 (getSystemCertificateStore)
35import System.X509 (getSystemCertificateStore)
29
36
30−import Control.Exception (try)
37+import Control.Monad.Catch (try)
31import Control.Monad.Except
38import Control.Monad.Except
32import Control.Monad.Reader.Class
39import Control.Monad.Reader.Class
33import Data.Text as T
40import Data.Text as T
@@ -38,20 +45,22 @@ import qualified Network.Socket.ByteString as SBS
38
45
39
46
40import Docker.Client.Internal (getEndpoint,
47import Docker.Client.Internal (getEndpoint,
48+ getEndpointContentType,
41 getEndpointRequestBody)
49 getEndpointRequestBody)
42import Docker.Client.Types (DockerClientOpts, Endpoint (..),
50import Docker.Client.Types (DockerClientOpts, Endpoint (..),
43− baseUrl)
51+ apiVer, baseUrl)
44
52
45type Request = HTTP.Request
53type Request = HTTP.Request
46type Response = HTTP.Response BL.ByteString
54type Response = HTTP.Response BL.ByteString
47type HttpVerb = StdMethod
55type HttpVerb = StdMethod
48−type HttpHandler m = Request -> m (Either DockerError Response)
56+newtype HttpHandler m = HttpHandler (forall a . Request -> (HTTP.Response () -> Sink BSC.ByteString m (Either DockerError a)) -> m (Either DockerError a))
49
57
50−data DockerError = DockerConnectionError
58+data DockerError = DockerConnectionError NHS.HttpException
51 | DockerInvalidRequest Endpoint
59 | DockerInvalidRequest Endpoint
60+ | DockerClientError Text
52 | DockerClientDecodeError Text -- ^ Could not parse the response from the Docker endpoint.
61 | DockerClientDecodeError Text -- ^ Could not parse the response from the Docker endpoint.
53 | DockerInvalidStatusCode HTTP.Status -- ^ Invalid exit code received from Docker endpoint.
62 | DockerInvalidStatusCode HTTP.Status -- ^ Invalid exit code received from Docker endpoint.
54− | GenericDockerError Text deriving (Eq, Show, Typeable)
63+ | GenericDockerError Text deriving (Show, Typeable)
55
64
56newtype DockerT m a = DockerT {
65newtype DockerT m a = DockerT {
57 unDockerT :: Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
66 unDockerT :: Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
@@ -75,6 +84,9 @@ instance MonadTrans DockerT where
75instance MonadIO m => MonadIO (DockerT m) where
84instance MonadIO m => MonadIO (DockerT m) where
76 liftIO = lift . liftIO
85 liftIO = lift . liftIO
77
86
87+-- instance MonadBase IO m => MonadBase IO (DockerT m) where
88+-- liftBase = liftBaseDefault
89+
78runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
90runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
79runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
91runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
80
92
@@ -84,28 +96,41 @@ runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
84-- benefit from testing that on all of our Endpoints
96-- benefit from testing that on all of our Endpoints
85mkHttpRequest :: HttpVerb -> Endpoint -> DockerClientOpts -> Maybe Request
97mkHttpRequest :: HttpVerb -> Endpoint -> DockerClientOpts -> Maybe Request
86mkHttpRequest verb e opts = request
98mkHttpRequest verb e opts = request
87− where fullE = T.unpack (baseUrl opts) ++ T.unpack (getEndpoint e)
99+ where fullE = T.unpack (baseUrl opts) ++ T.unpack (getEndpoint (apiVer opts) e)
88− initialR = parseUrl fullE
100+ initialR = parseRequest fullE
89 request' = case initialR of
101 request' = case initialR of
90 Just ir ->
102 Just ir ->
91 return $ ir {method = (encodeUtf8 . T.pack $ show verb),
103 return $ ir {method = (encodeUtf8 . T.pack $ show verb),
92− requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}
104+ requestHeaders = [("Content-Type", (getEndpointContentType e))]}
93 Nothing -> Nothing
105 Nothing -> Nothing
94− request = (\r -> maybe r (\body -> r {requestBody = HTTP.RequestBodyLBS body,
106+ request = (\r -> maybe r (\body -> r {requestBody = body, -- This will either be a HTTP.RequestBodyLBS or HTTP.RequestBodySourceChunked for the build endpoint
95 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'
107 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'
96 -- Note: Do we need to set length header?
108 -- Note: Do we need to set length header?
97
109
98−defaultHttpHandler :: MonadIO m => HttpHandler m
110+defaultHttpHandler :: (
111+#if MIN_VERSION_http_conduit(2,3,0)
112+ MonadUnliftIO m,
113+#endif
114+ MonadIO m, MonadMask m) => m (HttpHandler m)
99−defaultHttpHandler request = do
115+defaultHttpHandler = do
100 manager <- liftIO $ newManager defaultManagerSettings
116 manager <- liftIO $ newManager defaultManagerSettings
101− httpHandler manager request
117+ return $ httpHandler manager
102−
118+
119+httpHandler :: (
120+#if MIN_VERSION_http_conduit(2,3,0)
121+ MonadUnliftIO m,
122+#endif
103−httpHandler :: MonadIO m => HTTP.Manager -> HttpHandler m
123+ MonadIO m, MonadMask m) => HTTP.Manager -> HttpHandler m
104−httpHandler manager request = liftIO $ do
124+httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..
125+ let request = NHS.setRequestManager manager request'
105− try (httpLbs request manager) >>= \res -> case res of
126+ try (NHS.httpSink request sink) >>= \res -> case res of
106− Right res -> return $ Right 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
107− Left HTTP.FailedConnectionException{} -> return $ Left DockerConnectionError
131+ Left e@HTTP.FailedConnectionException{} -> return $ Left $ DockerConnectionError e
108− Left HTTP.FailedConnectionException2{} -> return $ Left DockerConnectionError
132+ Left e@HTTP.FailedConnectionException2{} -> return $ Left $ DockerConnectionError e
133+#endif
109 Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
134 Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
110
135
111-- | Connect to a unix domain socket (the default docker socket is
136-- | Connect to a unix domain socket (the default docker socket is
@@ -113,13 +138,17 @@ httpHandler manager request = liftIO $ do
113--
138--
114-- 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
115-- 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
116−unixHttpHandler :: MonadIO m => FilePath -- ^ The socket to connect to
145+ MonadIO m, MonadMask m) => FilePath -- ^ The socket to connect to
117− -> HttpHandler m
146+ -> m (HttpHandler m)
118−unixHttpHandler fp request = do
147+unixHttpHandler fp = do
119 let mSettings = defaultManagerSettings
148 let mSettings = defaultManagerSettings
120 { managerRawConnection = return $ openUnixSocket fp}
149 { managerRawConnection = return $ openUnixSocket fp}
121 manager <- liftIO $ newManager mSettings
150 manager <- liftIO $ newManager mSettings
122− httpHandler manager request
151+ return $ httpHandler manager
123
152
124 where
153 where
125 openUnixSocket filePath _ _ _ = do
154 openUnixSocket filePath _ _ _ = do
@@ -127,7 +156,7 @@ unixHttpHandler fp request = do
127 S.connect s (S.SockAddrUnix filePath)
156 S.connect s (S.SockAddrUnix filePath)
128 makeConnection (SBS.recv s 8096)
157 makeConnection (SBS.recv s 8096)
129 (SBS.sendAll s)
158 (SBS.sendAll s)
130− (S.sClose s)
159+ (S.close s)
131
160
132-- TODO:
161-- TODO:
133-- Move this to http-client-tls or network?
162-- Move this to http-client-tls or network?
@@ -194,6 +223,11 @@ statusCodeToError (StopContainerEndpoint _ _) st =
194 Nothing
223 Nothing
195 else
224 else
196 Just $ DockerInvalidStatusCode st
225 Just $ DockerInvalidStatusCode st
226+statusCodeToError (WaitContainerEndpoint _) st =
227+ if st == status200 then
228+ Nothing
229+ else
230+ Just $ DockerInvalidStatusCode st
197statusCodeToError (KillContainerEndpoint _ _) st =
231statusCodeToError (KillContainerEndpoint _ _) st =
198 if st == status204 then
232 if st == status204 then
199 Nothing
233 Nothing
@@ -229,5 +263,28 @@ statusCodeToError (InspectContainerEndpoint _) st =
229 Nothing
263 Nothing
230 else
264 else
231 Just $ DockerInvalidStatusCode st
265 Just $ DockerInvalidStatusCode st
232−
266+statusCodeToError (BuildImageEndpoint _ _) st =
233−
267+ if st == status200 then
268+ Nothing
269+ else
270+ Just $ DockerInvalidStatusCode st
271+statusCodeToError (CreateImageEndpoint _ _ _) st =
272+ if st == status200 then
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
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+60−27
@@ -1,14 +1,17 @@
1module Docker.Client.Internal where
1module Docker.Client.Internal where
2
2
3−
4import Blaze.ByteString.Builder (toByteString)
3import Blaze.ByteString.Builder (toByteString)
5import qualified Data.Aeson as JSON
4import qualified Data.Aeson as JSON
6import Data.ByteString (ByteString)
5import Data.ByteString (ByteString)
7−import qualified Data.ByteString.Lazy as BSL
6+import qualified Data.ByteString.Char8 as BSC
7+import 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)
10+import qualified Network.HTTP.Client as HTTP
11+import Network.HTTP.Conduit (requestBodySourceChunked)
10import Network.HTTP.Types (Query, encodePath,
12import Network.HTTP.Types (Query, encodePath,
11 encodePathSegments)
13 encodePathSegments)
14+import Prelude hiding (all)
12
15
13import Docker.Client.Types
16import Docker.Client.Types
14
17
@@ -22,50 +25,68 @@ encodeURLWithQuery ps q = decodeUtf8 $ toByteString $ encodePath ps q
22encodeQ :: String -> ByteString
25encodeQ :: String -> ByteString
23encodeQ = encodeUtf8 . T.pack
26encodeQ = encodeUtf8 . T.pack
24
27
25−getEndpoint :: Endpoint -> T.Text
28+getEndpoint :: ApiVersion -> Endpoint -> T.Text
26−getEndpoint VersionEndpoint = encodeURL ["version"]
29+getEndpoint v VersionEndpoint = encodeURL [v, "version"]
27−getEndpoint (ListContainersEndpoint _) = encodeURL ["containers", "json"] -- Make use of lsOpts here
30+getEndpoint v (ListContainersEndpoint (ListOpts all)) = encodeURLWithQuery [v, "containers", "json"] [("all", Just (encodeQ $ show all))]
28−getEndpoint (ListImagesEndpoint _) = encodeURL ["images", "json"] -- Make use of lsOpts here
31+getEndpoint v (ListImagesEndpoint _) = encodeURL [v, "images", "json"] -- Make use of lsOpts here
29−getEndpoint (CreateContainerEndpoint _ cn) = case cn of
32+getEndpoint v (CreateContainerEndpoint _ cn) = case cn of
30− Just cn -> encodeURLWithQuery ["containers", "create"] [("name", Just (encodeQ $ T.unpack cn))]
33+ Just cn -> encodeURLWithQuery [v, "containers", "create"] [("name", Just (encodeQ $ T.unpack cn))]
31− Nothing -> encodeURL ["containers", "create"]
34+ Nothing -> encodeURL [v, "containers", "create"]
32−getEndpoint (StartContainerEndpoint startOpts cid) = encodeURLWithQuery ["containers", fromContainerID cid, "start"] query
35+getEndpoint v (StartContainerEndpoint startOpts cid) = encodeURLWithQuery [v, "containers", fromContainerID cid, "start"] query
33 where query = case (detachKeys startOpts) of
36 where query = case (detachKeys startOpts) of
34 WithCtrl c -> [("detachKeys", Just (encodeQ $ ctrl ++ [c]))]
37 WithCtrl c -> [("detachKeys", Just (encodeQ $ ctrl ++ [c]))]
35 WithoutCtrl c -> [("detachKeys", Just (encodeQ [c]))]
38 WithoutCtrl c -> [("detachKeys", Just (encodeQ [c]))]
36 DefaultDetachKey -> []
39 DefaultDetachKey -> []
37 ctrl = ['c', 't', 'r', 'l', '-']
40 ctrl = ['c', 't', 'r', 'l', '-']
38−getEndpoint (StopContainerEndpoint t cid) = encodeURLWithQuery ["containers", fromContainerID cid, "stop"] query
41+getEndpoint v (StopContainerEndpoint t cid) = encodeURLWithQuery [v, "containers", fromContainerID cid, "stop"] query
39 where query = case t of
42 where query = case t of
40− Timeout x -> [("t", Just (encodeQ $ show x))]
43+ Timeout x -> [("t", Just (encodeQ $ show x))]
41 DefaultTimeout -> []
44 DefaultTimeout -> []
45+getEndpoint v (WaitContainerEndpoint cid) = encodeURL [v, "containers", fromContainerID cid, "wait"]
42−getEndpoint (KillContainerEndpoint s cid) = encodeURLWithQuery ["containers", fromContainerID cid, "kill"] query
46+getEndpoint v (KillContainerEndpoint s cid) = encodeURLWithQuery [v, "containers", fromContainerID cid, "kill"] query
43 where query = case s of
47 where query = case s of
44 SIG x -> [("signal", Just (encodeQ $ show x))]
48 SIG x -> [("signal", Just (encodeQ $ show x))]
45− _ -> [("signal", Just (encodeQ $ show s))]
49+ _ -> [("signal", Just (encodeQ $ show s))]
46−getEndpoint (RestartContainerEndpoint t cid) = encodeURLWithQuery ["containers", fromContainerID cid, "restart"] query
50+getEndpoint v (RestartContainerEndpoint t cid) = encodeURLWithQuery [v, "containers", fromContainerID cid, "restart"] query
47 where query = case t of
51 where query = case t of
48− Timeout x -> [("t", Just (encodeQ $ show x))]
52+ Timeout x -> [("t", Just (encodeQ $ show x))]
49 DefaultTimeout -> []
53 DefaultTimeout -> []
50−getEndpoint (PauseContainerEndpoint cid) = encodeURL ["containers", fromContainerID cid, "pause"]
54+getEndpoint v (PauseContainerEndpoint cid) = encodeURL [v, "containers", fromContainerID cid, "pause"]
51−getEndpoint (UnpauseContainerEndpoint cid) = encodeURL ["containers", fromContainerID cid, "unpause"]
55+getEndpoint v (UnpauseContainerEndpoint cid) = encodeURL [v, "containers", fromContainerID cid, "unpause"]
52-- Make use of since/timestamps/tail logopts here instead of ignoreing them
56-- Make use of since/timestamps/tail logopts here instead of ignoreing them
53−getEndpoint (ContainerLogsEndpoint (LogOpts stdout stderr _ _ _) follow cid) =
57+getEndpoint v (ContainerLogsEndpoint (LogOpts stdout stderr _ _ _) follow cid) =
54− encodeURLWithQuery ["containers", fromContainerID cid, "logs"] query
58+ encodeURLWithQuery [v, "containers", fromContainerID cid, "logs"] query
55 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))]
56−getEndpoint (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =
60+getEndpoint v (DeleteContainerEndpoint (ContainerDeleteOpts removeVolumes force) cid) =
57− encodeURLWithQuery ["containers", fromContainerID cid] query
61+ encodeURLWithQuery [v, "containers", fromContainerID cid] query
58 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))]
59−getEndpoint (InspectContainerEndpoint cid) =
63+getEndpoint v (InspectContainerEndpoint cid) =
60− encodeURLWithQuery ["containers", fromContainerID cid, "json"] []
64+ encodeURLWithQuery [v, "containers", fromContainerID cid, "json"] []
65+getEndpoint v (BuildImageEndpoint o _) = encodeURLWithQuery [v, "build"] query
66+ where query = [("t", Just t), ("dockerfile", Just dockerfile), ("q", Just q), ("nocache", Just nocache), ("rm", Just rm), ("forcerm", Just forcerm), ("pull", Just pull)]
67+ t = encodeQ $ T.unpack $ buildImageName o
68+ dockerfile = encodeQ $ T.unpack $ buildDockerfileName o
69+ q = encodeQ $ show $ buildQuiet o
70+ nocache = encodeQ $ show $ buildNoCache o
71+ rm = encodeQ $ show $ buildRemoveItermediate o
72+ forcerm = encodeQ $ show $ buildForceRemoveIntermediate o
73+ pull = encodeQ $ show $ buildPullParent o
74+getEndpoint v (CreateImageEndpoint name tag _) = encodeURLWithQuery [v, "images", "create"] query
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]
79+getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"]
80+getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid]
61
81
62−getEndpointRequestBody :: Endpoint -> Maybe BSL.ByteString
82+getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody
63getEndpointRequestBody VersionEndpoint = Nothing
83getEndpointRequestBody VersionEndpoint = Nothing
64getEndpointRequestBody (ListContainersEndpoint _) = Nothing
84getEndpointRequestBody (ListContainersEndpoint _) = Nothing
65getEndpointRequestBody (ListImagesEndpoint _) = Nothing
85getEndpointRequestBody (ListImagesEndpoint _) = Nothing
66−getEndpointRequestBody (CreateContainerEndpoint opts _) = Just $ JSON.encode opts
86+getEndpointRequestBody (CreateContainerEndpoint opts _) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)
67getEndpointRequestBody (StartContainerEndpoint _ _) = Nothing
87getEndpointRequestBody (StartContainerEndpoint _ _) = Nothing
68getEndpointRequestBody (StopContainerEndpoint _ _) = Nothing
88getEndpointRequestBody (StopContainerEndpoint _ _) = Nothing
89+getEndpointRequestBody (WaitContainerEndpoint _) = Nothing
69getEndpointRequestBody (KillContainerEndpoint _ _) = Nothing
90getEndpointRequestBody (KillContainerEndpoint _ _) = Nothing
70getEndpointRequestBody (RestartContainerEndpoint _ _) = Nothing
91getEndpointRequestBody (RestartContainerEndpoint _ _) = Nothing
71getEndpointRequestBody (PauseContainerEndpoint _) = Nothing
92getEndpointRequestBody (PauseContainerEndpoint _) = Nothing
@@ -73,3 +94,15 @@ getEndpointRequestBody (UnpauseContainerEndpoint _) = Nothing
73getEndpointRequestBody (ContainerLogsEndpoint _ _ _) = Nothing
94getEndpointRequestBody (ContainerLogsEndpoint _ _ _) = Nothing
74getEndpointRequestBody (DeleteContainerEndpoint _ _) = Nothing
95getEndpointRequestBody (DeleteContainerEndpoint _ _) = Nothing
75getEndpointRequestBody (InspectContainerEndpoint _) = Nothing
96getEndpointRequestBody (InspectContainerEndpoint _) = Nothing
97+
98+getEndpointRequestBody (BuildImageEndpoint _ fp) = Just $ requestBodySourceChunked $ CB.sourceFile fp
99+getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing
100+getEndpointRequestBody (DeleteImageEndpoint _ _) = Nothing
101+
102+getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)
103+getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing
104+
105+getEndpointContentType :: Endpoint -> BSC.ByteString
106+getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar"
107+getEndpointContentType _ = BSC.pack "application/json; charset=utf-8"
108+
src/Docker/Client/Types.hs+302−126
@@ -11,7 +11,11 @@ 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(..)
18+ , StatusCode(..)
15 , Signal(..)
19 , Signal(..)
16 , ContainerDetails(..)
20 , ContainerDetails(..)
17 , DockerClientOpts(..)
21 , DockerClientOpts(..)
@@ -22,23 +26,30 @@ module Docker.Client.Types (
22 , ContainerPortInfo(..)
26 , ContainerPortInfo(..)
23 , Container(..)
27 , Container(..)
24 , ContainerState(..)
28 , ContainerState(..)
25− , Status(..)
29+ , State(..)
26 , Digest
30 , Digest
27 , Label(..)
31 , Label(..)
28 , Tag
32 , Tag
29 , Image(..)
33 , Image(..)
34+ , Entrypoint(..)
30 , dropImagePrefix
35 , dropImagePrefix
31 , CreateOpts(..)
36 , CreateOpts(..)
37+ , BuildOpts(..)
38+ , defaultBuildOpts
32 , defaultCreateOpts
39 , defaultCreateOpts
33 , DetachKeys(..)
40 , DetachKeys(..)
34 , StartOpts(..)
41 , StartOpts(..)
35 , defaultStartOpts
42 , defaultStartOpts
36− , DeleteOpts(..)
43+ , ContainerDeleteOpts(..)
37− , defaultDeleteOpts
44+ , defaultContainerDeleteOpts
45+ , ImageDeleteOpts(..)
46+ , defaultImageDeleteOpts
38 , Timestamp
47 , Timestamp
39 , TailLogOpt(..)
48 , TailLogOpt(..)
40 , LogOpts(..)
49 , LogOpts(..)
41 , defaultLogOpts
50 , defaultLogOpts
51+ , CreateNetworkOpts(..)
52+ , defaultCreateNetworkOpts
42 , VolumePermission(..)
53 , VolumePermission(..)
43 , Bind(..)
54 , Bind(..)
44 , Volume(..)
55 , Volume(..)
@@ -52,7 +63,7 @@ module Docker.Client.Types (
52 , NetworkMode(..)
63 , NetworkMode(..)
53 , PortType(..)
64 , PortType(..)
54-- , NetworkInterface(..)
65-- , NetworkInterface(..)
55− , Networks(..)
66+ , Network(..)
56 , NetworkSettings(..)
67 , NetworkSettings(..)
57 , NetworkOptions(..)
68 , NetworkOptions(..)
58 , Mount(..)
69 , Mount(..)
@@ -64,6 +75,8 @@ module Docker.Client.Types (
64 , UTSMode(..)
75 , UTSMode(..)
65 , HostConfig(..)
76 , HostConfig(..)
66 , defaultHostConfig
77 , defaultHostConfig
78+ , NetworkingConfig(..)
79+ , EndpointConfig(..)
67 , Ulimit(..)
80 , Ulimit(..)
68 , ContainerResources(..)
81 , ContainerResources(..)
69 , defaultContainerResources
82 , defaultContainerResources
@@ -83,6 +96,8 @@ module Docker.Client.Types (
83 , addLink
96 , addLink
84 , addVolume
97 , addVolume
85 , addVolumeFrom
98 , addVolumeFrom
99+ , MemoryConstraint(..)
100+ , MemoryConstraintSize(..)
86 ) where
101 ) where
87
102
88import Data.Aeson (FromJSON, ToJSON, genericParseJSON,
103import Data.Aeson (FromJSON, ToJSON, genericParseJSON,
@@ -92,11 +107,12 @@ import qualified Data.Aeson as JSON
92import Data.Aeson.Types (defaultOptions, fieldLabelModifier)
107import Data.Aeson.Types (defaultOptions, fieldLabelModifier)
93import Data.Char (isAlphaNum, toUpper)
108import Data.Char (isAlphaNum, toUpper)
94import qualified Data.HashMap.Strict as HM
109import qualified Data.HashMap.Strict as HM
95−import qualified Data.Map as M
96import Data.Monoid ((<>))
110import Data.Monoid ((<>))
111+import Data.Scientific (floatingOrInteger)
97import Data.Text (Text)
112import Data.Text (Text)
98import qualified Data.Text as T
113import qualified Data.Text as T
99import Data.Time.Clock (UTCTime)
114import Data.Time.Clock (UTCTime)
115+import qualified Data.Vector as V
100import GHC.Generics (Generic)
116import GHC.Generics (Generic)
101import Prelude hiding (all, tail)
117import Prelude hiding (all, tail)
102import Text.Read (readMaybe)
118import Text.Read (readMaybe)
@@ -109,14 +125,20 @@ data Endpoint =
109 | CreateContainerEndpoint CreateOpts (Maybe ContainerName)
125 | CreateContainerEndpoint CreateOpts (Maybe ContainerName)
110 | StartContainerEndpoint StartOpts ContainerID
126 | StartContainerEndpoint StartOpts ContainerID
111 | StopContainerEndpoint Timeout ContainerID
127 | StopContainerEndpoint Timeout ContainerID
128+ | WaitContainerEndpoint ContainerID
112 | KillContainerEndpoint Signal ContainerID
129 | KillContainerEndpoint Signal ContainerID
113 | RestartContainerEndpoint Timeout ContainerID
130 | RestartContainerEndpoint Timeout ContainerID
114 | PauseContainerEndpoint ContainerID
131 | PauseContainerEndpoint ContainerID
115 | UnpauseContainerEndpoint ContainerID
132 | UnpauseContainerEndpoint ContainerID
116 | 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.
117 -- See note in 'Docker.Client.Api.getContainerLogs' for explanation why.
134 -- See note in 'Docker.Client.Api.getContainerLogs' for explanation why.
118− | DeleteContainerEndpoint DeleteOpts ContainerID
135+ | DeleteContainerEndpoint ContainerDeleteOpts ContainerID
119 | InspectContainerEndpoint ContainerID
136 | InspectContainerEndpoint ContainerID
137+ | BuildImageEndpoint BuildOpts FilePath
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
120 deriving (Eq, Show)
142 deriving (Eq, Show)
121
143
122-- | We should newtype this
144-- | We should newtype this
@@ -163,6 +185,20 @@ toImageID t =
163-- | Timeout used for stopping a container. DefaultTimeout is 10 seconds.
185-- | Timeout used for stopping a container. DefaultTimeout is 10 seconds.
164data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show)
186data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show)
165
187
188+data StatusCode = StatusCode Int
189+
190+instance ToJSON StatusCode where
191+ toJSON (StatusCode c) = object ["StatusCode" .= c]
192+
193+instance FromJSON StatusCode where
194+ parseJSON (JSON.Object o) = do
195+ c <- o .: "StatusCode"
196+ if c >= 0 && c <= 255 then
197+ return (StatusCode c)
198+ else
199+ fail "Unknown exit code"
200+ parseJSON _ = fail "Unknown exit code"
201+
166-- TODO: Add more Signals or use an existing lib
202-- TODO: Add more Signals or use an existing lib
167-- | Signal used for sending to the process running in the container.
203-- | Signal used for sending to the process running in the container.
168-- The default signal is SIGTERM.
204-- The default signal is SIGTERM.
@@ -177,16 +213,16 @@ data Signal = SIGHUP
177
213
178instance FromJSON Signal where
214instance FromJSON Signal where
179 parseJSON (JSON.String "SIGTERM") = return SIGTERM
215 parseJSON (JSON.String "SIGTERM") = return SIGTERM
180− parseJSON (JSON.String "SIGHUP") = return SIGHUP -- Note: Guessing on the string values for these.
216+ parseJSON (JSON.String "SIGHUP") = return SIGHUP -- Note: Guessing on the string values for these.
181− parseJSON (JSON.String "SIGINT") = return SIGINT
217+ parseJSON (JSON.String "SIGINT") = return SIGINT
182 parseJSON (JSON.String "SIGQUIT") = return SIGQUIT
218 parseJSON (JSON.String "SIGQUIT") = return SIGQUIT
183 parseJSON (JSON.String "SIGSTOP") = return SIGSTOP
219 parseJSON (JSON.String "SIGSTOP") = return SIGSTOP
184 parseJSON (JSON.String "SIGUSR1") = return SIGUSR1
220 parseJSON (JSON.String "SIGUSR1") = return SIGUSR1
185− parseJSON _ = fail "Unknown Signal"
221+ parseJSON _ = fail "Unknown Signal"
186
222
187instance ToJSON Signal where
223instance ToJSON Signal where
188− toJSON SIGHUP = "SIGHUP"
224+ toJSON SIGHUP = "SIGHUP"
189− toJSON SIGINT = "SIGINT"
225+ toJSON SIGINT = "SIGINT"
190 toJSON SIGQUIT = "SIGQUIT"
226 toJSON SIGQUIT = "SIGQUIT"
191 toJSON SIGSTOP = "SIGSTOP"
227 toJSON SIGSTOP = "SIGSTOP"
192 toJSON SIGTERM = "SIGTERM"
228 toJSON SIGTERM = "SIGTERM"
@@ -214,7 +250,7 @@ data ContainerDetails = ContainerDetails {
214 , processLabel :: Text
250 , processLabel :: Text
215 , resolveConfPath :: FilePath
251 , resolveConfPath :: FilePath
216 , restartCount :: Int
252 , restartCount :: Int
217− , state :: ContainerState
253+ , containerDetailsState :: ContainerState
218 , mounts :: [Mount]
254 , mounts :: [Mount]
219 }
255 }
220 deriving (Eq, Show, Generic)
256 deriving (Eq, Show, Generic)
@@ -222,11 +258,11 @@ data ContainerDetails = ContainerDetails {
222-- | Data type used for parsing the mount information from a container
258-- | Data type used for parsing the mount information from a container
223-- list.
259-- list.
224data Mount = Mount {
260data Mount = Mount {
225− mountName :: Text
261+ mountName :: Maybe Text -- this is optional
226 , mountSource :: FilePath
262 , mountSource :: FilePath
227 , mountDestination :: FilePath
263 , mountDestination :: FilePath
228− , mountDriver :: Text
264+ , mountDriver :: Maybe Text
229− , mountMode :: Maybe VolumePermission -- apparently this can be null
265+ -- , mountMode :: Maybe VolumePermission -- apparently this can be null
230 , mountRW :: Bool
266 , mountRW :: Bool
231 , mountPropogation :: Text
267 , mountPropogation :: Text
232 }
268 }
@@ -234,14 +270,14 @@ data Mount = Mount {
234
270
235instance FromJSON Mount where
271instance FromJSON Mount where
236 parseJSON (JSON.Object o) = do
272 parseJSON (JSON.Object o) = do
237− name <- o .: "Name"
273+ name <- o .:? "Name"
238 src <- o .: "Source"
274 src <- o .: "Source"
239 dest <- o .: "Destination"
275 dest <- o .: "Destination"
240− driver <- o .: "Driver"
276+ driver <- o .:? "Driver"
241− mode <- o .: "Mode"
277+ -- mode <- o .: "Mode"
242 rw <- o .: "RW"
278 rw <- o .: "RW"
243 prop <- o .: "Propagation"
279 prop <- o .: "Propagation"
244− return $ Mount name src dest driver mode rw prop
280+ return $ Mount name src dest driver rw prop
245 parseJSON _ = fail "Mount is not an object"
281 parseJSON _ = fail "Mount is not an object"
246
282
247-- | 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
@@ -257,7 +293,7 @@ data ContainerState = ContainerState {
257 , restarting :: Bool
293 , restarting :: Bool
258 , running :: Bool
294 , running :: Bool
259 , startedAt :: UTCTime
295 , startedAt :: UTCTime
260− , status :: Status
296+ , state :: State
261 }
297 }
262 deriving (Eq, Show, Generic)
298 deriving (Eq, Show, Generic)
263
299
@@ -420,20 +456,17 @@ instance FromJSON NetworkOptions where
420 parseJSON _ = fail "NetworkOptions is not an object"
456 parseJSON _ = fail "NetworkOptions is not an object"
421
457
422-- TODO: Not sure what this is used for anymore.
458-- TODO: Not sure what this is used for anymore.
423−newtype Networks = Networks (M.Map NetworkMode NetworkOptions) -- Note: Is it ever possible that there will be duplicates of network modes?
459+data Network = Network NetworkMode NetworkOptions
424 deriving (Eq, Show)
460 deriving (Eq, Show)
425
461
426−instance FromJSON Networks where
462+instance {-# OVERLAPPING #-} FromJSON [Network] where
427− parseJSON (JSON.Object o) = do
463+ parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
428− Networks <$> HM.foldlWithKey' f (return M.empty) o
429−
430 where
464 where
431 f accM k' v' = do
465 f accM k' v' = do
432 acc <- accM
466 acc <- accM
433 k <- parseJSON $ JSON.String k'
467 k <- parseJSON $ JSON.String k'
434 v <- parseJSON v'
468 v <- parseJSON v'
435− return $ M.insert k v acc
469+ return $ (Network k v):acc
436−
437 parseJSON _ = fail "Networks is not an object"
470 parseJSON _ = fail "Networks is not an object"
438
471
439-- | Data type reprsenting the various network settings a container can have.
472-- | Data type reprsenting the various network settings a container can have.
@@ -455,7 +488,7 @@ data NetworkSettings = NetworkSettings {
455 , networkSettingsIpPrefixLen :: Int
488 , networkSettingsIpPrefixLen :: Int
456 , networkSettingsIpv6Gateway :: Text
489 , networkSettingsIpv6Gateway :: Text
457 , networkSettingsMacAddress :: Text
490 , networkSettingsMacAddress :: Text
458− , networkSettingsNetworks :: Networks
491+ , networkSettingsNetworks :: [Network]
459 }
492 }
460 deriving (Eq, Show)
493 deriving (Eq, Show)
461
494
@@ -490,21 +523,23 @@ data Container = Container
490 , containerImageId :: ImageID
523 , containerImageId :: ImageID
491 , containerCommand :: Text
524 , containerCommand :: Text
492 , containerCreatedAt :: Int
525 , containerCreatedAt :: Int
526+ , containerState :: State
493− , containerStatus :: Status
527+ , containerStatus :: Maybe Text
494 , containerPorts :: [ContainerPortInfo]
528 , containerPorts :: [ContainerPortInfo]
495 , containerLabels :: [Label]
529 , containerLabels :: [Label]
496− , containerNetworks :: Networks
530+ , containerNetworks :: [Network]
497 , containerMounts :: [Mount]
531 , containerMounts :: [Mount]
498 } deriving (Show, Eq)
532 } deriving (Show, Eq)
499
533
500instance FromJSON Container where
534instance FromJSON Container where
501− parseJSON (JSON.Object v) =
535+ parseJSON o@(JSON.Object v) =
502− Container <$> (v .: "Id")
536+ Container <$> parseJSON o
503 <*> (v .: "Names")
537 <*> (v .: "Names")
504 <*> (v .: "Image")
538 <*> (v .: "Image")
505− <*> (v .: "ImageID")
539+ <*> (v .: "ImageID") -- Doesn't exist anymore
506− <*> (v .: "Command")
540+ <*> (v .: "Command") -- Doesn't exist anymore
507 <*> (v .: "Created")
541 <*> (v .: "Created")
542+ <*> (v .: "State")
508 <*> (v .: "Status")
543 <*> (v .: "Status")
509 <*> (v .: "Ports")
544 <*> (v .: "Ports")
510 <*> (v .: "Labels")
545 <*> (v .: "Labels")
@@ -514,21 +549,20 @@ instance FromJSON Container where
514 parseNetworks (JSON.Object v) =
549 parseNetworks (JSON.Object v) =
515 (v .: "Networks") >>= parseJSON
550 (v .: "Networks") >>= parseJSON
516 parseNetworks _ = fail "Container NetworkSettings: Not a JSON object."
551 parseNetworks _ = fail "Container NetworkSettings: Not a JSON object."
517−
518 parseJSON _ = fail "Container: Not a JSON object."
552 parseJSON _ = fail "Container: Not a JSON object."
519
553
520−-- | Represents the status of the container life cycle.
554+-- | Represents the state of the container life cycle.
521−data Status = Created | Restarting | Running | Paused | Exited | Dead
555+data State = Created | Restarting | Running | Paused | Exited | Dead
522 deriving (Eq, Show, Generic)
556 deriving (Eq, Show, Generic)
523
557
524−instance FromJSON Status where
558+instance FromJSON State where
525− parseJSON (JSON.String "running") = return Running
559+ parseJSON (JSON.String "running") = return Running
526− 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.
527 parseJSON (JSON.String "restarting") = return Restarting
561 parseJSON (JSON.String "restarting") = return Restarting
528− parseJSON (JSON.String "paused") = return Paused
562+ parseJSON (JSON.String "paused") = return Paused
529− parseJSON (JSON.String "exited") = return Exited
563+ parseJSON (JSON.String "exited") = return Exited
530− parseJSON (JSON.String "dead") = return Dead
564+ parseJSON (JSON.String "dead") = return Dead
531− parseJSON _ = fail "Unknown Status"
565+ parseJSON s = fail $ "Unknown Status: " ++ show s
532
566
533-- | Alias for representing a RepoDigest. We could newtype this and add
567-- | Alias for representing a RepoDigest. We could newtype this and add
534-- some validation.
568-- some validation.
@@ -540,13 +574,13 @@ data Label = Label Name Value deriving (Eq, Show)
540
574
541-- If there are multiple lables with the same Name in the list
575-- If there are multiple lables with the same Name in the list
542-- then the last one wins.
576-- then the last one wins.
543−instance ToJSON [Label] where
577+instance {-# OVERLAPPING #-} ToJSON [Label] where
544 toJSON [] = emptyJsonObject
578 toJSON [] = emptyJsonObject
545 toJSON (l:ls) = toJsonKeyVal (l:ls) key val
579 toJSON (l:ls) = toJsonKeyVal (l:ls) key val
546 where key (Label k _) = T.unpack k
580 where key (Label k _) = T.unpack k
547 val (Label _ v) = v
581 val (Label _ v) = v
548
582
549−instance FromJSON [Label] where
583+instance {-# OVERLAPPING #-} FromJSON [Label] where
550 parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
584 parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
551 where f accM k v = do
585 where f accM k v = do
552 acc <- accM
586 acc <- accM
@@ -563,8 +597,8 @@ data Image = DockerImage {
563 imageId :: ImageID
597 imageId :: ImageID
564 , imageCreated :: Integer
598 , imageCreated :: Integer
565 , imageParentId :: Maybe ImageID
599 , imageParentId :: Maybe ImageID
566− , imageRepoTags :: Maybe [Tag]
600+ , imageRepoTags :: [Tag]
567− , imageRepoDigests :: Maybe [Digest]
601+ , imageRepoDigests :: [Digest]
568 , imageSize :: Integer
602 , imageSize :: Integer
569 , imageVirtualSize :: Integer
603 , imageVirtualSize :: Integer
570 , imageLabels :: [Label]
604 , imageLabels :: [Label]
@@ -581,30 +615,54 @@ instance FromJSON Image where
581 imageId <- o .: "Id"
615 imageId <- o .: "Id"
582 imageCreated <- o .: "Created"
616 imageCreated <- o .: "Created"
583 imageParentId <- o .:? "ParentId"
617 imageParentId <- o .:? "ParentId"
584− imageRepoTags <- o .:? "RepoTags"
618+ imageRepoTags <- o .:? "RepoTags" .!= []
585− imageRepoDigests <- o .:? "RepoDigests"
619+ imageRepoDigests <- o .:? "RepoDigests" .!= []
586 imageSize <- o .: "Size"
620 imageSize <- o .: "Size"
587 imageVirtualSize <- o .: "VirtualSize"
621 imageVirtualSize <- o .: "VirtualSize"
588− imageLabels <- case HM.lookup "Labels" o of
622+ imageLabels <- o .:? "Labels" .!= []
589− Just ls -> parseJSON ls
590− Nothing -> return []
591 return $ DockerImage imageId imageCreated imageParentId imageRepoTags imageRepoDigests imageSize imageVirtualSize imageLabels
623 return $ DockerImage imageId imageCreated imageParentId imageRepoTags imageRepoDigests imageSize imageVirtualSize imageLabels
592 parseJSON _ = fail "Failed to parse DockerImage."
624 parseJSON _ = fail "Failed to parse DockerImage."
593
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+ ]
594
649
595-- | Options used for creating a Container.
650-- | Options used for creating a Container.
596data CreateOpts = CreateOpts {
651data CreateOpts = CreateOpts {
597− containerConfig :: ContainerConfig
652+ containerConfig :: ContainerConfig
598− , hostConfig :: HostConfig
653+ , hostConfig :: HostConfig
654+ , networkingConfig :: NetworkingConfig
599 } deriving (Eq, Show)
655 } deriving (Eq, Show)
600
656
601instance ToJSON CreateOpts where
657instance ToJSON CreateOpts where
602− toJSON (CreateOpts cc hc) = do
658+ toJSON (CreateOpts cc hc nc) = do
603 let ccJSON = toJSON cc
659 let ccJSON = toJSON cc
604 let hcJSON = toJSON hc
660 let hcJSON = toJSON hc
605 case ccJSON of
661 case ccJSON of
606 JSON.Object (o :: HM.HashMap T.Text JSON.Value) -> do
662 JSON.Object (o :: HM.HashMap T.Text JSON.Value) -> do
607− 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
608 _ -> error "ContainerConfig is not an object." -- This should never happen.
666 _ -> error "ContainerConfig is not an object." -- This should never happen.
609
667
610-- | Container configuration used for creating a container with sensible
668-- | Container configuration used for creating a container with sensible
@@ -626,7 +684,7 @@ defaultContainerConfig imageName = ContainerConfig {
626 , cmd=[]
684 , cmd=[]
627 , volumes=[]
685 , volumes=[]
628 , workingDir=Nothing
686 , workingDir=Nothing
629− , entrypoint=Nothing
687+ , entrypoint=Entrypoint []
630 , networkDisabled=Nothing
688 , networkDisabled=Nothing
631 , macAddress=Nothing
689 , macAddress=Nothing
632 , labels=[]
690 , labels=[]
@@ -639,7 +697,7 @@ defaultHostConfig = HostConfig {
639 binds=[]
697 binds=[]
640 , containerIDFile=Nothing
698 , containerIDFile=Nothing
641 , logConfig=LogDriverConfig JsonFile []
699 , logConfig=LogDriverConfig JsonFile []
642− , networkMode=Bridge
700+ , networkMode=NetworkBridge
643 , portBindings=[]
701 , portBindings=[]
644 , restartPolicy=RestartOff
702 , restartPolicy=RestartOff
645 , volumeDriver=Nothing
703 , volumeDriver=Nothing
@@ -679,14 +737,18 @@ defaultContainerResources = ContainerResources {
679 , memory=Nothing
737 , memory=Nothing
680 , memoryReservation=Nothing
738 , memoryReservation=Nothing
681 , memorySwap=Nothing
739 , memorySwap=Nothing
682− , oomKillDisable=False
740+ , oomKillDisable=Just False
683 , ulimits=[]
741 , ulimits=[]
684 }
742 }
685
743
686-- | Default create options when creating a container. You only need to
744-- | Default create options when creating a container. You only need to
687-- specify an image name and the rest is all sensible defaults.
745-- specify an image name and the rest is all sensible defaults.
688defaultCreateOpts :: T.Text -> CreateOpts
746defaultCreateOpts :: T.Text -> CreateOpts
747+defaultCreateOpts imageName = CreateOpts
689−defaultCreateOpts imageName = CreateOpts { containerConfig = defaultContainerConfig imageName, hostConfig = defaultHostConfig }
748+ { containerConfig = defaultContainerConfig imageName
749+ , hostConfig = defaultHostConfig
750+ , networkingConfig = NetworkingConfig HM.empty
751+ }
690
752
691-- | Override the key sequence for detaching a container.
753-- | Override the key sequence for detaching a container.
692-- 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 _.
@@ -700,16 +762,45 @@ defaultStartOpts :: StartOpts
700defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }
762defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }
701
763
702-- | Options for deleting a container.
764-- | Options for deleting a container.
703−data DeleteOpts = DeleteOpts {
765+data ContainerDeleteOpts = ContainerDeleteOpts {
704 deleteVolumes :: Bool -- ^ Automatically cleanup volumes that the container created as well.
766 deleteVolumes :: Bool -- ^ Automatically cleanup volumes that the container created as well.
705 , force :: Bool -- ^ If the container is still running force deletion anyway.
767 , force :: Bool -- ^ If the container is still running force deletion anyway.
706 } deriving (Eq, Show)
768 } deriving (Eq, Show)
707
769
770+-- TODO: Add support for container build constraints
771+-- | Options for when building images from a Dockerfile
772+data BuildOpts = BuildOpts {
773+ buildImageName :: Text -- ^ Image name in the form of name:tag; ie. myimage:latest.:w
774+ , buildDockerfileName :: Text -- ^ Name of dockerfile (default: Dockerfile)
775+ , buildQuiet :: Bool
776+ , buildNoCache :: Bool -- ^ Do not use cache when building the image.
777+ , buildRemoveItermediate :: Bool -- ^ Remove intermediate containers after a successful build (default true).
778+ , buildForceRemoveIntermediate :: Bool -- ^ Always remove intermediate containers.
779+ , buildPullParent :: Bool -- ^ Always attempt to pull a newer version of the *parent* image (ie. FROM debian:jessie).
780+ } deriving (Eq, Show)
781+
782+defaultBuildOpts :: Text -> BuildOpts
783+defaultBuildOpts nameTag = BuildOpts { buildImageName = nameTag
784+ , buildDockerfileName = "Dockerfile"
785+ , buildQuiet = False
786+ , buildNoCache = False
787+ , buildRemoveItermediate = True
788+ , buildForceRemoveIntermediate = False
789+ , buildPullParent = False
790+ }
791+
708-- | 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
709-- 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
710-- running.
794-- running.
711−defaultDeleteOpts :: DeleteOpts
795+defaultContainerDeleteOpts :: ContainerDeleteOpts
712−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
713
804
714-- | Timestamp alias.
805-- | Timestamp alias.
715type Timestamp = Integer
806type Timestamp = Integer
@@ -737,18 +828,50 @@ defaultLogOpts = LogOpts { stdout = True
737 , tail = All
828 , tail = All
738 }
829 }
739
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+
740-- 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")
741-- | Set permissions on volumes that you mount in the container.
862-- | Set permissions on volumes that you mount in the container.
742data VolumePermission = ReadWrite | ReadOnly deriving (Eq, Show, Generic)
863data VolumePermission = ReadWrite | ReadOnly deriving (Eq, Show, Generic)
743
864
744instance ToJSON VolumePermission where
865instance ToJSON VolumePermission where
745 toJSON ReadWrite = "rw"
866 toJSON ReadWrite = "rw"
746− toJSON ReadOnly = "ro"
867+ toJSON ReadOnly = "ro"
747
868
748instance FromJSON VolumePermission where
869instance FromJSON VolumePermission where
749 parseJSON "rw" = return ReadWrite
870 parseJSON "rw" = return ReadWrite
750 parseJSON "ro" = return ReadOnly
871 parseJSON "ro" = return ReadOnly
872+ parseJSON "RW" = return ReadWrite
873+ parseJSON "RO" = return ReadOnly
751− parseJSON _ = fail "Failed to parse VolumePermission"
874+ parseJSON _ = fail "Failed to parse VolumePermission"
752
875
753-- | Used for marking a directory in the container as "exposed" hence
876-- | Used for marking a directory in the container as "exposed" hence
754-- taking it outside of the COW filesystem and making it mountable
877-- taking it outside of the COW filesystem and making it mountable
@@ -763,15 +886,15 @@ instance FromJSON VolumePermission where
763-- @
886-- @
764newtype Volume = Volume FilePath deriving (Eq, Show)
887newtype Volume = Volume FilePath deriving (Eq, Show)
765
888
766−instance ToJSON [Volume] where
889+instance {-# OVERLAPPING #-} ToJSON [Volume] where
767 toJSON [] = emptyJsonObject
890 toJSON [] = emptyJsonObject
768 toJSON (v:vs) = toJsonKey (v:vs) getKey
891 toJSON (v:vs) = toJsonKey (v:vs) getKey
769 where getKey (Volume v) = v
892 where getKey (Volume v) = v
770
893
771−instance FromJSON [Volume] where
894+instance {-# OVERLAPPING #-} FromJSON [Volume] where
772 parseJSON (JSON.Object o) = return $ map (Volume . T.unpack) $ HM.keys o
895 parseJSON (JSON.Object o) = return $ map (Volume . T.unpack) $ HM.keys o
773− parseJSON (JSON.Null) = return []
896+ parseJSON (JSON.Null) = return []
774− parseJSON _ = fail "Volume is not an object"
897+ parseJSON _ = fail "Volume is not an object"
775
898
776
899
777data Bind = Bind { hostSrc :: Text
900data Bind = Bind { hostSrc :: Text
@@ -781,10 +904,10 @@ data Bind = Bind { hostSrc :: Text
781
904
782instance FromJSON Bind where
905instance FromJSON Bind where
783 parseJSON (JSON.String t) = case T.split (== ':') t of
906 parseJSON (JSON.String t) = case T.split (== ':') t of
784− [src, dest] -> return $ Bind src dest Nothing
907+ [src, dest] -> return $ Bind src dest Nothing
785 [src, dest, "rw"] -> return $ Bind src dest $ Just ReadWrite
908 [src, dest, "rw"] -> return $ Bind src dest $ Just ReadWrite
786 [src, dest, "ro"] -> return $ Bind src dest $ Just ReadOnly
909 [src, dest, "ro"] -> return $ Bind src dest $ Just ReadOnly
787− _ -> fail "Could not parse Bind"
910+ _ -> fail "Could not parse Bind"
788 parseJSON _ = fail "Bind is not a string"
911 parseJSON _ = fail "Bind is not a string"
789
912
790data Device = Device {
913data Device = Device {
@@ -807,15 +930,15 @@ data VolumeFrom = VolumeFrom ContainerName (Maybe VolumePermission) deriving (Eq
807
930
808instance FromJSON VolumeFrom where
931instance FromJSON VolumeFrom where
809 parseJSON (JSON.String t) = case T.split (== ':') t of
932 parseJSON (JSON.String t) = case T.split (== ':') t of
810− [vol] -> return $ VolumeFrom vol Nothing
933+ [vol] -> return $ VolumeFrom vol Nothing
811 [vol, "rw"] -> return $ VolumeFrom vol $ Just ReadWrite
934 [vol, "rw"] -> return $ VolumeFrom vol $ Just ReadWrite
812 [vol, "ro"] -> return $ VolumeFrom vol $ Just ReadOnly
935 [vol, "ro"] -> return $ VolumeFrom vol $ Just ReadOnly
813− _ -> fail "Could not parse VolumeFrom"
936+ _ -> fail "Could not parse VolumeFrom"
814 parseJSON _ = fail "VolumeFrom is not a string"
937 parseJSON _ = fail "VolumeFrom is not a string"
815
938
816instance ToJSON VolumeFrom where
939instance ToJSON VolumeFrom where
817 toJSON (VolumeFrom n p) = case p of
940 toJSON (VolumeFrom n p) = case p of
818− Nothing -> toJSON $ n <> ":" <> "rw"
941+ Nothing -> toJSON $ n <> ":" <> "rw"
819 Just per -> toJSON $ n <> ":" <> (T.pack $ show per)
942 Just per -> toJSON $ n <> ":" <> (T.pack $ show per)
820
943
821instance ToJSON Bind where
944instance ToJSON Bind where
@@ -827,51 +950,51 @@ data Link = Link Text (Maybe Text) deriving (Eq, Show)
827
950
828instance FromJSON Link where
951instance FromJSON Link where
829 parseJSON (JSON.String t) = case T.split (== ':') t of
952 parseJSON (JSON.String t) = case T.split (== ':') t of
830− [f] -> return $ Link f Nothing
953+ [f] -> return $ Link f Nothing
831 [f,s] -> return $ Link f $ Just s
954 [f,s] -> return $ Link f $ Just s
832− _ -> fail "Could not parse Link"
955+ _ -> fail "Could not parse Link"
833 parseJSON _ = fail "Link is not a string"
956 parseJSON _ = fail "Link is not a string"
834
957
835instance ToJSON Link where
958instance ToJSON Link where
836 toJSON (Link n1 n2) = toJSON $ case n2 of
959 toJSON (Link n1 n2) = toJSON $ case n2 of
837 Nothing -> T.concat[n1, ":", n1] -- use same name in container
960 Nothing -> T.concat[n1, ":", n1] -- use same name in container
838− Just n -> T.concat[n1, ":", n] -- used specified name in container
961+ Just n -> T.concat[n1, ":", n] -- used specified name in container
839
962
840-- { "Type": "<driver_name>", "Config": {"key1": "val1"} }
963-- { "Type": "<driver_name>", "Config": {"key1": "val1"} }
841data LogDriverType = JsonFile | Syslog | Journald | Gelf | Fluentd | AwsLogs | Splunk | Etwlogs | LoggingDisabled deriving (Eq, Show)
964data LogDriverType = JsonFile | Syslog | Journald | Gelf | Fluentd | AwsLogs | Splunk | Etwlogs | LoggingDisabled deriving (Eq, Show)
842
965
843instance FromJSON LogDriverType where
966instance FromJSON LogDriverType where
844 parseJSON (JSON.String "json-file") = return JsonFile
967 parseJSON (JSON.String "json-file") = return JsonFile
845− parseJSON (JSON.String "syslog") = return Syslog
968+ parseJSON (JSON.String "syslog") = return Syslog
846− parseJSON (JSON.String "journald") = return Journald
969+ parseJSON (JSON.String "journald") = return Journald
847− parseJSON (JSON.String "gelf") = return Gelf
970+ parseJSON (JSON.String "gelf") = return Gelf
848− parseJSON (JSON.String "fluentd") = return Fluentd
971+ parseJSON (JSON.String "fluentd") = return Fluentd
849− parseJSON (JSON.String "awslogs") = return AwsLogs
972+ parseJSON (JSON.String "awslogs") = return AwsLogs
850− parseJSON (JSON.String "splunk") = return Splunk
973+ parseJSON (JSON.String "splunk") = return Splunk
851− parseJSON (JSON.String "etwlogs") = return Etwlogs
974+ parseJSON (JSON.String "etwlogs") = return Etwlogs
852− parseJSON (JSON.String "none") = return LoggingDisabled
975+ parseJSON (JSON.String "none") = return LoggingDisabled
853− parseJSON _ = fail "Unknown LogDriverType"
976+ parseJSON _ = fail "Unknown LogDriverType"
854
977
855instance ToJSON LogDriverType where
978instance ToJSON LogDriverType where
856− toJSON JsonFile = JSON.String "json-file"
979+ toJSON JsonFile = JSON.String "json-file"
857− toJSON Syslog = JSON.String "syslog"
980+ toJSON Syslog = JSON.String "syslog"
858− toJSON Journald = JSON.String "journald"
981+ toJSON Journald = JSON.String "journald"
859− toJSON Gelf = JSON.String "gelf"
982+ toJSON Gelf = JSON.String "gelf"
860− toJSON Fluentd = JSON.String "fluentd"
983+ toJSON Fluentd = JSON.String "fluentd"
861− toJSON AwsLogs = JSON.String "awslogs"
984+ toJSON AwsLogs = JSON.String "awslogs"
862− toJSON Splunk = JSON.String "splunk"
985+ toJSON Splunk = JSON.String "splunk"
863− toJSON Etwlogs = JSON.String "etwlogs"
986+ toJSON Etwlogs = JSON.String "etwlogs"
864 toJSON LoggingDisabled = JSON.String "none"
987 toJSON LoggingDisabled = JSON.String "none"
865
988
866data LogDriverOption = LogDriverOption Name Value deriving (Eq, Show)
989data LogDriverOption = LogDriverOption Name Value deriving (Eq, Show)
867
990
868−instance ToJSON [LogDriverOption] where
991+instance {-# OVERLAPPING #-} ToJSON [LogDriverOption] where
869 toJSON [] = emptyJsonObject
992 toJSON [] = emptyJsonObject
870 toJSON (o:os) = toJsonKeyVal (o:os) key val
993 toJSON (o:os) = toJsonKeyVal (o:os) key val
871 where key (LogDriverOption n _) = T.unpack n
994 where key (LogDriverOption n _) = T.unpack n
872 val (LogDriverOption _ v) = v
995 val (LogDriverOption _ v) = v
873
996
874−instance FromJSON [LogDriverOption] where
997+instance {-# OVERLAPPING #-} FromJSON [LogDriverOption] where
875 parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
998 parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
876 where f accM k v = do
999 where f accM k v = do
877 acc <- accM
1000 acc <- accM
@@ -894,19 +1017,41 @@ instance FromJSON LogDriverConfig where
894 parseJSON _ = fail "LogDriverConfig is not an object"
1017 parseJSON _ = fail "LogDriverConfig is not an object"
895
1018
896-- TODO: Add container:<name|id> mode
1019-- TODO: Add container:<name|id> mode
897−data NetworkMode = Bridge | Host | NetworkDisabled
1020+data NetworkMode = NetworkBridge | NetworkHost | NetworkDisabled | NetworkNamed Text
898 deriving (Eq, Show, Ord)
1021 deriving (Eq, Show, Ord)
899
1022
900instance FromJSON NetworkMode where
1023instance FromJSON NetworkMode where
901− parseJSON (JSON.String "bridge") = return Bridge
1024+ parseJSON (JSON.String "bridge") = return NetworkBridge
902− parseJSON (JSON.String "host") = return Host -- Note: Guessing on these.
1025+ parseJSON (JSON.String "host") = return NetworkHost -- Note: Guessing on these.
903− parseJSON (JSON.String "none") = return NetworkDisabled
1026+ parseJSON (JSON.String "none") = return NetworkDisabled
1027+ parseJSON (JSON.String n) = return $ NetworkNamed n
904− parseJSON _ = fail "Unknown NetworkMode"
1028+ parseJSON _ = fail "Unknown NetworkMode"
905
1029
906instance ToJSON NetworkMode where
1030instance ToJSON NetworkMode where
907− toJSON Bridge = JSON.String "bridge"
1031+ toJSON NetworkBridge = JSON.String "bridge"
908− toJSON Host = JSON.String "host"
1032+ toJSON NetworkHost = JSON.String "host"
909 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]
910
1055
911data PortType = TCP | UDP deriving (Eq, Generic, Read, Ord)
1056data PortType = TCP | UDP deriving (Eq, Generic, Read, Ord)
912
1057
@@ -922,7 +1067,7 @@ instance FromJSON PortType where
922 parseJSON val = case val of
1067 parseJSON val = case val of
923 "tcp" -> return TCP
1068 "tcp" -> return TCP
924 "udp" -> return UDP
1069 "udp" -> return UDP
925− _ -> fail "PortType: Invalid port type."
1070+ _ -> fail "PortType: Invalid port type."
926
1071
927-- newtype NetworkInterface = NetworkInterface Text deriving (Eq, Show)
1072-- newtype NetworkInterface = NetworkInterface Text deriving (Eq, Show)
928--
1073--
@@ -1003,7 +1148,7 @@ addExposedPort ep c = c{containerConfig=cc{exposedPorts=oldeps <> [ep]}}
1003 oldeps = exposedPorts cc
1148 oldeps = exposedPorts cc
1004
1149
1005
1150
1006−instance FromJSON [PortBinding] where
1151+instance {-# OVERLAPPING #-} FromJSON [PortBinding] where
1007 parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
1152 parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
1008 where
1153 where
1009 f accM k v = case T.split (== '/') k of
1154 f accM k v = case T.split (== '/') k of
@@ -1017,7 +1162,7 @@ instance FromJSON [PortBinding] where
1017 parseJSON (JSON.Null) = return []
1162 parseJSON (JSON.Null) = return []
1018 parseJSON _ = fail "PortBindings is not an object"
1163 parseJSON _ = fail "PortBindings is not an object"
1019
1164
1020−instance ToJSON [PortBinding] where
1165+instance {-# OVERLAPPING #-} ToJSON [PortBinding] where
1021 toJSON [] = emptyJsonObject
1166 toJSON [] = emptyJsonObject
1022 toJSON (p:ps) = toJsonKeyVal (p:ps) key val
1167 toJSON (p:ps) = toJsonKeyVal (p:ps) key val
1023 where key p = T.unpack $ portAndType2Text (containerPort p) (portType p)
1168 where key p = T.unpack $ portAndType2Text (containerPort p) (portType p)
@@ -1052,7 +1197,7 @@ instance FromJSON RestartPolicy where
1052 "on-failure" -> do
1197 "on-failure" -> do
1053 retry <- o .: "MaximumRetryCount"
1198 retry <- o .: "MaximumRetryCount"
1054 return $ RestartOnFailure retry
1199 return $ RestartOnFailure retry
1055− "off" -> return RestartOff
1200+ "no" -> return RestartOff
1056 _ -> fail "Could not parse RestartPolicy"
1201 _ -> fail "Could not parse RestartPolicy"
1057 parseJSON _ = fail "RestartPolicy is not an object"
1202 parseJSON _ = fail "RestartPolicy is not an object"
1058
1203
@@ -1060,7 +1205,7 @@ instance ToJSON RestartPolicy where
1060 toJSON RestartAlways = object ["Name" .= JSON.String "always"]
1205 toJSON RestartAlways = object ["Name" .= JSON.String "always"]
1061 toJSON RestartUnlessStopped = object ["Name" .= JSON.String "unless-stopped"]
1206 toJSON RestartUnlessStopped = object ["Name" .= JSON.String "unless-stopped"]
1062 toJSON (RestartOnFailure c) = object ["Name" .= JSON.String "on-failure", "MaximumRetryCount" .= c]
1207 toJSON (RestartOnFailure c) = object ["Name" .= JSON.String "on-failure", "MaximumRetryCount" .= c]
1063− toJSON RestartOff = object ["Name" .= JSON.String "off"]
1208+ toJSON RestartOff = object ["Name" .= JSON.String "no"]
1064
1209
1065data Isolation = Default | Process | Hyperv deriving (Eq, Show)
1210data Isolation = Default | Process | Hyperv deriving (Eq, Show)
1066
1211
@@ -1233,6 +1378,22 @@ instance ToJSON DeviceRate where
1233 , "Rate" .= r
1378 , "Rate" .= r
1234 ]
1379 ]
1235
1380
1381+data MemoryConstraintSize = B | MB | GB deriving (Eq, Show)
1382+
1383+data MemoryConstraint = MemoryConstraint Integer MemoryConstraintSize deriving (Eq, Show)
1384+
1385+instance ToJSON MemoryConstraint where
1386+ toJSON (MemoryConstraint x B) = toJSON x
1387+ toJSON (MemoryConstraint x MB) = toJSON $ x * 1024 * 1024
1388+ toJSON (MemoryConstraint x GB) = toJSON $ x * 1024 * 1024 * 1024
1389+
1390+instance FromJSON MemoryConstraint where
1391+ parseJSON (JSON.Number x) = case (floatingOrInteger x) of
1392+ Left (_ :: Double) -> fail "Failed to parse MemoryConstraint"
1393+ Right i -> return $ MemoryConstraint i B
1394+ -- The docker daemon will always return the number as bytes (integer), regardless of how we set them (using MB or GB)
1395+ parseJSON _ = fail "Failed to parse MemoryConstraint"
1396+
1236data ContainerResources = ContainerResources {
1397data ContainerResources = ContainerResources {
1237 cpuShares :: Maybe Integer
1398 cpuShares :: Maybe Integer
1238 -- , cgroupParent :: Text -- 1.24: Missing from inspecting container details... Going to omit for now.
1399 -- , cgroupParent :: Text -- 1.24: Missing from inspecting container details... Going to omit for now.
@@ -1248,12 +1409,12 @@ data ContainerResources = ContainerResources {
1248 , cpusetMems :: Maybe Text
1409 , cpusetMems :: Maybe Text
1249 , devices :: [Device]
1410 , devices :: [Device]
1250 -- , diskQuota :: Integer -- Don't see this ins 1.24.
1411 -- , diskQuota :: Integer -- Don't see this ins 1.24.
1251− , kernelMemory :: Maybe Integer
1412+ , kernelMemory :: Maybe MemoryConstraint
1252− , memory :: Maybe Integer
1413+ , memory :: Maybe MemoryConstraint
1253− , memoryReservation :: Maybe Integer
1414+ , memoryReservation :: Maybe MemoryConstraint
1254− , memorySwap :: Maybe Integer
1415+ , memorySwap :: Maybe MemoryConstraint
1255 -- , 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.
1256− , oomKillDisable :: Bool
1417+ , oomKillDisable :: Maybe Bool
1257 -- , 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.
1258 , ulimits :: [Ulimit]
1419 , ulimits :: [Ulimit]
1259 -- TODO: Missing from 1.24
1420 -- TODO: Missing from 1.24
@@ -1291,7 +1452,7 @@ instance FromJSON EnvVar where
1291 parseJSON _ = fail "EnvVar is not a string"
1452 parseJSON _ = fail "EnvVar is not a string"
1292
1453
1293instance ToJSON EnvVar where
1454instance ToJSON EnvVar where
1294− toJSON (EnvVar n v) = object [n .= v]
1455+ toJSON (EnvVar n v) = JSON.String $ n <> T.pack "=" <> v
1295
1456
1296-- | ExposedPort represents a port (and it's type)
1457-- | ExposedPort represents a port (and it's type)
1297-- 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.
@@ -1312,7 +1473,7 @@ instance ToJSON EnvVar where
1312-- @
1473-- @
1313data ExposedPort = ExposedPort Port PortType deriving (Eq, Show)
1474data ExposedPort = ExposedPort Port PortType deriving (Eq, Show)
1314
1475
1315−instance FromJSON [ExposedPort] where
1476+instance {-# OVERLAPPING #-} FromJSON [ExposedPort] where
1316 parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
1477 parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
1317 where
1478 where
1318 f accM k _ = case T.split (== '/') k of
1479 f accM k _ = case T.split (== '/') k of
@@ -1325,12 +1486,27 @@ instance FromJSON [ExposedPort] where
1325 parseJSON (JSON.Null) = return []
1486 parseJSON (JSON.Null) = return []
1326 parseJSON _ = fail "ExposedPorts is not an object"
1487 parseJSON _ = fail "ExposedPorts is not an object"
1327
1488
1328−instance ToJSON [ExposedPort] where
1489+instance {-# OVERLAPPING #-} ToJSON [ExposedPort] where
1329 toJSON [] = emptyJsonObject
1490 toJSON [] = emptyJsonObject
1330 toJSON (p:ps) = toJsonKey (p:ps) key
1491 toJSON (p:ps) = toJsonKey (p:ps) key
1331 where key (ExposedPort p t) = show p <> slash <> show t
1492 where key (ExposedPort p t) = show p <> slash <> show t
1332 slash = T.unpack "/"
1493 slash = T.unpack "/"
1333
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+
1334data ContainerConfig = ContainerConfig {
1510data ContainerConfig = ContainerConfig {
1335 hostname :: Maybe Text
1511 hostname :: Maybe Text
1336 , domainname :: Maybe Text
1512 , domainname :: Maybe Text
@@ -1349,7 +1525,7 @@ data ContainerConfig = ContainerConfig {
1349 , image :: Text
1525 , image :: Text
1350 , volumes :: [Volume]
1526 , volumes :: [Volume]
1351 , workingDir :: Maybe FilePath
1527 , workingDir :: Maybe FilePath
1352− , entrypoint :: Maybe Text -- Can be null?
1528+ , entrypoint :: Entrypoint
1353 , 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?
1354 , macAddress :: Maybe Text
1530 , macAddress :: Maybe Text
1355 -- , 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.
@@ -1357,6 +1533,7 @@ data ContainerConfig = ContainerConfig {
1357 , stopSignal :: Signal
1533 , stopSignal :: Signal
1358 } deriving (Eq, Show, Generic)
1534 } deriving (Eq, Show, Generic)
1359
1535
1536+
1360instance ToJSON ContainerConfig where
1537instance ToJSON ContainerConfig where
1361 toJSON = genericToJSON defaultOptions {
1538 toJSON = genericToJSON defaultOptions {
1362 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
1539 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
@@ -1369,9 +1546,7 @@ instance FromJSON ContainerConfig where
1369 attachStdin <- o .: "AttachStdin"
1546 attachStdin <- o .: "AttachStdin"
1370 attachStdout <- o .: "AttachStdout"
1547 attachStdout <- o .: "AttachStdout"
1371 attachStderr <- o .: "AttachStderr"
1548 attachStderr <- o .: "AttachStderr"
1372− exposedPorts <- case HM.lookup "ExposedPorts" o of
1549+ exposedPorts <- o .:? "ExposedPorts" .!= []
1373− Just eps -> parseJSON eps
1374− Nothing -> return []
1375 tty <- o .: "Tty"
1550 tty <- o .: "Tty"
1376 openStdin <- o .: "OpenStdin"
1551 openStdin <- o .: "OpenStdin"
1377 stdinOnce <- o .: "StdinOnce"
1552 stdinOnce <- o .: "StdinOnce"
@@ -1380,18 +1555,20 @@ instance FromJSON ContainerConfig where
1380 image <- o .: "Image"
1555 image <- o .: "Image"
1381 volumes <- o .: "Volumes"
1556 volumes <- o .: "Volumes"
1382 workingDir <- o .:? "WorkingDir"
1557 workingDir <- o .:? "WorkingDir"
1383− entrypoint <- o .:? "Entrypoint"
1558+ entrypoint <- o .: "Entrypoint"
1384 networkDisabled <- o .:? "networkDisabled"
1559 networkDisabled <- o .:? "networkDisabled"
1385 macAddress <- o .:? "MacAddress"
1560 macAddress <- o .:? "MacAddress"
1386− labels <- case HM.lookup "Labels" o of
1561+ labels <- o .:? "Labels" .!= []
1387− Just ls -> parseJSON ls
1388− Nothing -> return []
1389 stopSignal <- o .: "StopSignal"
1562 stopSignal <- o .: "StopSignal"
1390 return $ ContainerConfig hostname domainname user attachStdin attachStdout attachStderr exposedPorts tty openStdin stdinOnce env cmd image volumes workingDir entrypoint networkDisabled
1563 return $ ContainerConfig hostname domainname user attachStdin attachStdout attachStderr exposedPorts tty openStdin stdinOnce env cmd image volumes workingDir entrypoint networkDisabled
1391 macAddress labels stopSignal
1564 macAddress labels stopSignal
1392 parseJSON _ = fail "NetworkSettings is not an object."
1565 parseJSON _ = fail "NetworkSettings is not an object."
1393
1566
1567+#if MIN_VERSION_base(4,13,0)
1568+parseIntegerText :: (MonadFail m) => Text -> m Integer
1569+#else
1394parseIntegerText :: (Monad m) => Text -> m Integer
1570parseIntegerText :: (Monad m) => Text -> m Integer
1571+#endif
1395parseIntegerText t = case readMaybe $ T.unpack t of
1572parseIntegerText t = case readMaybe $ T.unpack t of
1396 Nothing ->
1573 Nothing ->
1397 fail "Could not parse Integer"
1574 fail "Could not parse Integer"
@@ -1413,4 +1590,3 @@ toJsonKeyVal vs getKey getVal = JSON.Object $ foldl f HM.empty vs
1413-- | Helper function that return an empty dictionary "{}"
1590-- | Helper function that return an empty dictionary "{}"
1414emptyJsonObject :: JSON.Value
1591emptyJsonObject :: JSON.Value
1415emptyJsonObject = JSON.Object HM.empty
1592emptyJsonObject = JSON.Object HM.empty
1416−
src/Docker/Client/Utils.hsnew file+131
@@ -0,0 +1,131 @@
1+{-# LANGUAGE ExplicitForAll #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+
5+
6+module Docker.Client.Utils where
7+
8+import qualified Codec.Archive.Tar as Tar
9+import qualified Codec.Compression.GZip as GZip
10+import Control.Monad (filterM, liftM, unless)
11+import Control.Monad.IO.Class
12+import qualified Data.ByteString.Lazy as BS
13+import Data.Monoid ((<>))
14+import qualified Data.Text as T
15+import qualified Data.Text.IO as TIO
16+import qualified Data.UUID as UUID
17+import qualified Data.UUID.V4 as UUID
18+import System.Directory (doesDirectoryExist, doesFileExist,
19+ getTemporaryDirectory)
20+import System.FilePath (isAbsolute, makeRelative, (</>))
21+import System.FilePath.Find (FilterPredicate,
22+ RecursionPredicate, always,
23+ fileName, find, (==?))
24+import System.FilePath.GlobPattern ((~~))
25+import System.IO.Error (tryIOError)
26+-- import System.IO.Temp (withSystemTempDirectory)
27+--
28+import Docker.Client.Http
29+
30+type File = FilePath
31+data DirTree = DirTree [File] [DirTree]
32+
33+
34+newtype ExclusionPattern = ExclusionPattern T.Text deriving (Eq, Show)
35+newtype InclusionPattern = InclusionPattern T.Text deriving (Eq, Show)
36+
37+data DockerIgnore = DockerIgnore { exclusionPatterns :: [ExclusionPattern]
38+ , inclusionPatterns :: [InclusionPattern]
39+ } deriving (Eq, Show)
40+
41+newtype BuildContextRootDir = BuildContextRootDir FilePath deriving (Eq, Show)
42+
43+makeBuildContext :: forall m. MonadIO m => BuildContextRootDir -> m (Either DockerError FilePath)
44+makeBuildContext base = liftIO $ tryIOError (makeBuildContext' base) >>= \res -> case res of
45+ Left e -> return $ Left $ DockerClientError (T.pack $ show e)
46+ Right c -> return $ Right c
47+
48+makeBuildContext' :: forall m. MonadIO m => BuildContextRootDir -> m FilePath
49+makeBuildContext' (BuildContextRootDir base) = do
50+ uuid <- liftIO UUID.nextRandom
51+ fs <- liftIO $ getBuildContext $ BuildContextRootDir base
52+ let relFs = map (makeRelative base) fs
53+ tmpDir <- liftIO getTemporaryDirectory
54+ let tmpF = tmpDir </> "docker.context-" <> UUID.toString uuid <> ".tar.gz"
55+ liftIO $ BS.writeFile tmpF . GZip.compress . Tar.write =<< Tar.pack base relFs
56+ return tmpF
57+
58+parseDockerIgnoreFile :: T.Text -> DockerIgnore
59+parseDockerIgnoreFile c = DockerIgnore{ exclusionPatterns=parseExclusions
60+ , inclusionPatterns=parseInclusions}
61+ where lines = filter (not . T.isPrefixOf "#") (T.lines c) -- Ignore comments
62+ parseExclusions = map ExclusionPattern $ filter (\l -> not (T.isPrefixOf "!" l) && (l /= "")) lines
63+ parseInclusions = map (InclusionPattern . T.drop 1) $ filter (\l -> T.isPrefixOf "!" l && (l /= "")) lines
64+
65+getBuildContext :: BuildContextRootDir -> IO [FilePath]
66+getBuildContext (BuildContextRootDir base) = do
67+ -- The base dir needs to be a path to a directory and not a path to
68+ -- a file
69+ exists <- doesDirectoryExist base
70+ let abs = isAbsolute base
71+ unless (exists && abs) $ fail "Path to context needs to be a directory that: exists, is readable, and is an absolute path."
72+ di <- find always (fileName ==? ".dockerignore") base
73+ dockerignore <- case di of
74+ [] -> return $ DockerIgnore [] []
75+ -- This should not return more than one result though
76+ (x:_) -> do
77+ c <- TIO.readFile x
78+ return $ parseDockerIgnoreFile c
79+ -- This will traverse the directory recursively
80+ fs <- find (shouldRecurse dockerignore) (shouldInclude dockerignore) base
81+ -- fs is a list of directories *and* files in those directories. So
82+ -- an example result would look like ["/tmp/project/files",
83+ -- "/tmp/project/files/file1.txt"] and we want just the individual
84+ -- files otherwise tar duplicates them when making the archive.
85+ fs' <- filterM doesFileExist fs
86+ -- For some reason base is in there as well and we don't need that
87+ return $ filter (not . (==) base) fs'
88+
89+shouldInclude :: DockerIgnore -> FilterPredicate
90+shouldInclude d = check `liftM` fileName
91+ where check f = dockerIgnoreDecision (exclusionCheck f (exclusionPatterns d), inclusionCheck f (inclusionPatterns d))
92+
93+shouldRecurse :: DockerIgnore -> RecursionPredicate
94+shouldRecurse d = check `liftM` fileName
95+ where check f = dockerIgnoreDecision (exclusionCheck f (exclusionPatterns d), inclusionCheck f (inclusionPatterns d))
96+
97+-- TODO: We don't handle precedence rules. For instance a dockerignore file
98+-- like this:
99+--
100+-- *.md
101+-- !README*.md
102+-- README-secret.md
103+--
104+-- Should result in no markdown files being included in the context except README files other
105+-- than README-secret.md. FIXME: OUR implementation would in fact include
106+-- README-secret.md as well!!!
107+--
108+-- Whereas this:
109+--
110+-- *.md
111+-- README-secret.md
112+-- !README*.md
113+--
114+-- Should result in all of the README files being included. The middle line has no effect
115+-- because !README*.md matches README-secret.md and comes last. Our
116+-- implementation will result in the same thing.
117+dockerIgnoreDecision :: (Bool, Bool) -> Bool
118+dockerIgnoreDecision p = case p of
119+ -- If it's in any of the exclusion patterns but also
120+ -- in any of the inclusion patterns then laeave it
121+ (True, True) -> True
122+ (True, False) -> False
123+ (False, True) -> True
124+ (False, False) -> True
125+
126+exclusionCheck :: FilePath -> [ExclusionPattern] -> Bool
127+exclusionCheck f ps = any id (map (\(ExclusionPattern p) -> f ~~ T.unpack p) ps)
128+
129+inclusionCheck :: FilePath -> [InclusionPattern] -> Bool
130+inclusionCheck f ps = any id (map (\(InclusionPattern p) -> f ~~ T.unpack p) ps)
131+
stack-7.10.yamlnew file+32
@@ -0,0 +1,32 @@
1+# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
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-6.30
5+
6+# Local packages, usually specified by relative directory name
7+packages:
8+- '.'
9+
10+# Override default flag values for local packages and extra-deps
11+flags: {}
12+
13+# Extra package databases containing global packages
14+extra-deps:
15+- directory-1.2.7.0
16+- unliftio-core-0.1.1.0
17+- process-1.6.5.1
18+
19+# Control whether we use the GHC we find on the path
20+# system-ghc: true
21+
22+# Require a specific version of stack, using version ranges
23+# require-stack-version: -any # Default
24+# require-stack-version: >= 0.1.4.0
25+
26+# Override the architecture used by stack, especially useful on Windows
27+# arch: i386
28+# arch: x86_64
29+
30+# Extra directories used by stack for building
31+# extra-include-dirs: [/path/to/dir]
32+# extra-lib-dirs: [/path/to/dir]
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.yamlnew file+5
@@ -0,0 +1,5 @@
1+resolver: lts-7.12
2+packages:
3+- '.'
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.yamlmode 100644 → 120000+1−32
@@ -1,32 +0,0 @@
1−# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
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
5−
6−# Local packages, usually specified by relative directory name
7−packages:
8−- '.'
9−
10−# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
11−extra-deps: []
12−
13−# Override default flag values for local packages and extra-deps
14−flags: {}
15−
16−# Extra package databases containing global packages
17−extra-package-dbs: []
18−
19−# Control whether we use the GHC we find on the path
20−# system-ghc: true
21−
22−# Require a specific version of stack, using version ranges
23−# require-stack-version: -any # Default
24−# require-stack-version: >= 0.1.4.0
25−
26−# Override the architecture used by stack, especially useful on Windows
27−# arch: i386
28−# arch: x86_64
29−
30−# Extra directories used by stack for building
31−# extra-include-dirs: [/path/to/dir]
32−# extra-lib-dirs: [/path/to/dir]
@@ -0,0 +1 @@
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−79
@@ -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,134 +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
54+ h <- defaultHttpHandler
45− runDockerT (defaultClientOpts, defaultHttpHandler) f
55+ runDockerT (defaultClientOpts, h) f
46
56
47testDockerVersion :: IO ()
57testDockerVersion :: IO ()
48−testDockerVersion = runDocker $ do
58+testDockerVersion =
59+ runDocker $
49− v <- getDockerVersion
60+ do v <- getDockerVersion
50− 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
51
67
52testFindImage :: IO ()
68testFindImage :: IO ()
53−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
54 images <- listImages defaultListOpts >>= fromRight
87 images <- listImages defaultListOpts >>= fromRight
55− let xs = filter (tagFilter imageFullName) images
88+ return $ listToMaybe
56− lift $ assert $ length xs == 1
89+ $ filter (elem imageToDeleteFullName . imageRepoTags) images
57− where imageFullName = testImageName <> ":latest"
90+
58− tagFilter :: Text -> Image -> Bool
91+testListContainers :: IO ()
59− tagFilter t i = case (imageRepoTags i) of
92+testListContainers =
60− Nothing -> False
93+ runDocker $
61− Just tags -> elem t tags
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+
62
108
63testRunAndReadLog :: 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 =
64−testRunAndReadLog = runDocker $ do
117+ runDocker $
65− 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
66− c <- fromRight containerId
121+ c <- fromRight containerId
67− status1 <- startContainer defaultStartOpts c
122+ status1 <- startContainer defaultStartOpts c
68− _ <- inspectContainer c >>= fromRight
123+ _ <- inspectContainer c >>= fromRight
69− lift $ threadDelay 300000 -- give 300ms for the application to finish
124+ lift $ threadDelay 300000 -- give 300ms for the application to finish
70− lift $ assert $ status1 == Right ()
125+ lift $ assertBool ("starting the container, unexpected status: " ++ show status1) $ isRightUnit status1
71− status2 <- killContainer SIGTERM c
72− logs <- getContainerLogs defaultLogOpts c >>= fromRight
126+ logs <- getContainerLogs defaultLogOpts c >>= fromRight
73− lift $ assert $ status2 == Right ()
74− lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
127+ lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
75− status3 <- deleteContainer (DeleteOpts True True) c
128+ status3 <- deleteContainer (ContainerDeleteOpts True True) c
76− lift $ assert $ status3 == Right ()
129+ lift $ assertBool ("deleting container, unexpected status: " ++ show status3) $ isRightUnit status3
130+ mapM_ removeNetwork createdNetworks
131+ where
132+ isRightUnit (Right ()) = True
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
77
146
78testLogDriverOptionsJson :: TestTree
147testLogDriverOptionsJson :: TestTree
79−testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [ test1, test2, test3 ]
148+testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [test1, test2, test3]
80− where
149+ where
81− 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
82− 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 =
83− test3 = testCase "Test override" $ assert $ JSON.toJSON sample2 ^. key key1 . _String == "override"
153+ testCase "Test override" $ assert $ JSON.toJSON sample2 ^. key key1 . _String == "override"
84− sample = [LogDriverOption key1 val1, LogDriverOption key2 val2]
154+ sample = [LogDriverOption key1 val1, LogDriverOption key2 val2]
85− sample2 = [LogDriverOption key1 val1, LogDriverOption key1 "override"]
155+ sample2 = [LogDriverOption key1 val1, LogDriverOption key1 "override"]
86− key1 = "some-key"
156+ key1 = "some-key"
87− val1 = "some-val"
157+ val1 = "some-val"
88− key2 = "some-key2"
158+ key2 = "some-key2"
89− val2 = "some-key2"
159+ val2 = "some-key2"
90
160
91testExposedPortsJson :: TestTree
161testExposedPortsJson :: TestTree
92−testExposedPortsJson = testGroup "Testing ExposedPorts JSON" [ testTCP, testUDP ]
162+testExposedPortsJson = testGroup "Testing ExposedPorts JSON" [testTCP, testUDP]
93− where
163+ where
94− 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 =
95− 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
96− sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP]
167+ sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP]
97
168
98testLabelsJson :: TestTree
169testLabelsJson :: TestTree
99−testLabelsJson = testGroup "Testing Labels JSON" [ testLS1, testLS2, testOverride ]
170+testLabelsJson = testGroup "Testing Labels JSON" [testLS1, testLS2, testOverride]
100− where
171+ where
101− 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
102− 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 =
103− 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"
104− sampleLS = [Label key1 val1, Label key2 val2]
179+ sampleLS = [Label key1 val1, Label key2 val2]
105− key1 = "com.example.some-label"
180+ key1 = "com.example.some-label"
106− val1 = "some-value"
181+ val1 = "some-value"
107− key2 = "something"
182+ key2 = "something"
108− val2 = "value"
183+ val2 = "value"
109
184
110testVolumesJson :: TestTree
185testVolumesJson :: TestTree
111−testVolumesJson = testGroup "Testing Volumes JSON" [ testSample1, testSample2 ]
186+testVolumesJson = testGroup "Testing Volumes JSON" [testSample1, testSample2]
112− where
187+ where
188+ testSample1 =
113− 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 =
114− 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
115− 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+ ]
116
238
117integrationTests :: TestTree
239integrationTests :: TestTree
118−integrationTests = testGroup "Integration Tests" [
240+integrationTests =
241+ testGroup
242+ "Integration Tests"
119− testCase "Get docker version" testDockerVersion,
243+ [ testCase "Get docker version" testDockerVersion
244+ , testCase "Build image from Dockerfile" testBuildFromDockerfile
120− testCase "Find image by name" testFindImage,
245+ , testCase "Find image by name" testFindImage
246+ , testCase "Delete image" testDeleteImage
247+ , testCase "List containers" testListContainers
121− 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+ ]
122
253
123jsonTests :: TestTree
254jsonTests :: TestTree
124−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+ ]
125
266
126setup :: IO ()
267setup :: IO ()
268+setup =
269+ mapM_ system
270+ [ "docker pull " ++ unpack imageToDeleteFullName
127−setup = system ("docker build -t "++unpack testImageName++" tests") >> return ()
271+ , "docker build -t " ++ unpack testImageName ++ " tests"
272+ ]
273+
274+isLeft = not . isRight
128
275
129−isRight (Left _) = False
276+isRight (Left _) = False
130isRight (Right _) = True
277isRight (Right _) = True
131
278
279+fromRight
132−fromRight :: (MonadIO m, Show l) => Either l r -> m r
280+ :: (MonadIO m, Show l)
281+ => Either l r -> m r
133fromRight (Left l) = do
282fromRight (Left l) = do
134− liftIO $ assertFailure $ "Left: " ++ show l
283+ liftIO $ assertFailure $ "Left: " ++ show l
135− undefined
284+ undefined
136fromRight (Right r) = return r
285fromRight (Right r) = return r
137
286
138main :: IO ()
287main :: IO ()
139main = do
288main = do
289+ stackage <- lookupEnv "RUN_INTEGRATION_TESTS"
290+ case stackage of
291+ Nothing -> defaultMain $ testGroup "Tests" [jsonTests]
292+ Just _ -> do
140− setup
293+ setup
141− defaultMain $ testGroup "Tests" [jsonTests, integrationTests]
294+ defaultMain $ testGroup "Tests" [jsonTests, integrationTests]
142−