on 6b13d44 help sign in
.gitignore−2
since splitsnapshots
unifiedsplit
@@ -3,5 +3,3 @@
3/dist/
3/dist/
4*~
4*~
5.stack-work/
5.stack-work/
6−dist-newstyle
7−/cabal.project.local
.travis.yml+7−40
@@ -1,12 +1,6 @@
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−
10# Choose a lightweight base image; we provide our own build tools.
4# Choose a lightweight base image; we provide our own build tools.
11language:
5language:
12 c
6 c
@@ -22,30 +16,7 @@ services:
22 - docker
16 - docker
23
17
24env:
18env:
25− global:
26− - RUN_INTEGRATION_TESTS=1
27− - STACK_ARGS=""
19+ - 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
49
20
50addons:
21addons:
51 apt:
22 apt:
@@ -53,24 +24,20 @@ addons:
53 - libgmp-dev
24 - libgmp-dev
54
25
55before_install:
26before_install:
56− # Upgrade docker to 1.12.3.0
27+ # Upgrade docker to 1.12
57 - sudo sh -c 'echo "deb https://apt.dockerproject.org/repo ubuntu-trusty main" > /etc/apt/sources.list.d/docker.list'
28 - sudo sh -c 'echo "deb https://apt.dockerproject.org/repo ubuntu-trusty main" > /etc/apt/sources.list.d/docker.list'
58 - sudo apt-key adv --keyserver hkp://p80.pool.sks-keyservers.net:80 --recv-keys 58118E89F3A912897C070ADBF76221572C52609D
29 - sudo apt-key adv --keyserver hkp://p80.pool.sks-keyservers.net:80 --recv-keys 58118E89F3A912897C070ADBF76221572C52609D
59 - sudo apt-get update
30 - sudo apt-get update
60− - sudo apt-get -qqy -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confold" install docker-engine=$DOCKER_VERSION
31+ - sudo apt-get -qqy -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confold" install docker-engine=1.12.0-0~trusty
61−
62−install:
63 - mkdir -p "$HOME"/.local/bin
32 - mkdir -p "$HOME"/.local/bin
64 - export PATH=$HOME/.local/bin:$PATH
33 - export PATH=$HOME/.local/bin:$PATH
65− - export STACK_YAML=stack-$GHCVER.yaml
34+
66 # install Stack
35 # install 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'
36 - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C $HOME/.local/bin '*/stack'
68− - export PATH=$(stack path --local-install-root):$PATH
37+ - export PATH=$(stack --stack-yaml stack.yaml path --local-install-root):$PATH
69− - stack --version
38+ - stack setup
39+
70
40
71script:
41script:
72− - stack setup
73− - stack update
74− - stack build
75 - stack test
42 - stack test
76
43
CHANGELOG.md−79
@@ -1,84 +1,5 @@
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−
82## 0.2.0.4 (2016-02-11)
3## 0.2.0.4 (2016-02-11)
83
4
84- Adds function for getting all containers and images
5- Adds function for getting all containers and images
CONTRIBUTING.mddeleted−14
@@ -1,14 +0,0 @@
1−# Contributing
2−
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.
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) 2014, Deni Bertovic
1+Copyright (c) 2016, Deni Bertovic
2
2
3All rights reserved.
3All rights reserved.
4
4
Makefile+2−26
@@ -1,42 +1,18 @@
1−.PHONY: build repl test release help
1+.PHONY: test build repl release
2
2
3−.DEFAULT_GOAL = help
4−
5−PROJECT_NAME ?= $(shell grep "^name" docker.cabal | cut -d " " -f17)
6VERSION ?= $(shell grep "^version:" docker.cabal | cut -d " " -f14)
3VERSION ?= $(shell grep "^version:" docker.cabal | cut -d " " -f14)
7−RESOLVER ?= $(shell grep "^resolver:" stack.yaml | cut -d " " -f2)
8−GHC_VERSION ?= $(shell stack ghc -- --version | cut -d " " -f8)
9−ARCH=$(shell uname -m)
10
4
11−## Run build
12build:
5build:
13 @stack build
6 @stack build
14
7
15−## Run repl
16repl:
8repl:
17 @stack repl
9 @stack repl
18
10
19−## Run tests. Example RUN_INTEGRATION_TESTS=1 make test
20test:
11test:
21− @RUN_INTEGRATION_TESTS=1 stack test
12+ @stack test
22
13
23−## Cut new release
24release:
14release:
25 @stack build --haddock
15 @stack build --haddock
26 @stack sdist
16 @stack sdist
27 @echo "\n\nDone. Now run: \n\nstack upload <path_to_tarball>\n"
17 @echo "\n\nDone. Now run: \n\nstack upload <path_to_tarball>\n"
28− @echo "\nAnd: \n\ngit tag ${VERSION} && git push --tags\n"
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
18
README.md+10−35
@@ -1,48 +1,23 @@
1# An API client for docker written in Haskell
1# An API client for docker written in Haskell
2
2
3−| Master |
4−| -------|
5−| [![master](https://travis-ci.org/denibertovic/docker-hs.svg?branch=master)](https://travis-ci.org/denibertovic/docker-hs) |
3+Travis CI : [![Build Status](https://travis-ci.org/denibertovic/docker-hs.svg?branch=master)](https://travis-ci.org/denibertovic/docker-hs)
6−
7
4
8## Current state
5## Current state
9
6
10−Supported Docker Engine Api version: `v1.24` and onwards.
7+**Not production ready yet!**
11
8
12−Anything upward of that should work since Docker versions their API.
9+The library is going through a **total rewrite**.
13−Older docker version and engine api versions are not supported at the moment.
14
10
15−## Documentation
11+See [Issue #12](https://github.com/denibertovic/docker-hs/issues/12) for things
12+that need to happen before a new release.
16
13
17−The API-documentation is available at
18−[Hackage](https://hackage.haskell.org/package/docker). There are also some
19−usage-examples in the main library source file,
20−[`Client.hs`](https://hackage.haskell.org/package/docker/docs/Docker-Client.html).
21
14
22## Contributing
15## Contributing
23
16
24−Please see [CONTRIBUTING.md](CONTRIBUTING.md).
17+If you wish to contribute please see the Issue mentioned above or any issue tagged with "help wanted".
25−
18+Make sure to submit your PR's against the `dev` branch.
26−### Project Setup
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
19
45−## IRC
20+Please consider filling an Issue first and discuss design decisions and implementation details before
21+writing any code. This is so that no development cycles go to waste on implementing a feature that
22+might not get merged either because of implementation details or other reasons.
46
23
47−If you have any questions or suggestions you can find the maintainers in `#docker-haskell`
48−on freenode.
docker.cabal+20−51
@@ -1,7 +1,7 @@
1name: docker
1name: docker
2−version: 0.6.0.3
2+version: 0.3.0.0
3synopsis: An API client for docker written in Haskell
3synopsis: An API client for docker written in Haskell
4−description: See API documentation below.
4+description: See README.md
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,57 +14,28 @@ 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−
22library
17library
23− default-extensions: DeriveGeneric, OverloadedStrings, ScopedTypeVariables, ExplicitForAll, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes, DeriveFunctor, FlexibleInstances, CPP
18+ default-extensions: DeriveGeneric, OverloadedStrings, ScopedTypeVariables, ExplicitForAll, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes, DeriveFunctor, FlexibleInstances
24 hs-source-dirs: src
19 hs-source-dirs: src
25− exposed-modules: Docker.Client, Docker.Client.Api, Docker.Client.Types, Docker.Client.Internal, Docker.Client.Http, Docker.Client.Utils
20+ exposed-modules: Docker.Client, Docker.Client.Api, Docker.Client.Types, Docker.Client.Internal, Docker.Client.Http
26 -- other-modules: Docker.Internal
21 -- other-modules: Docker.Internal
27 build-depends: base >= 4.7 && < 5
22 build-depends: base >= 4.7 && < 5
28− , aeson >= 0.9.0 && < 2.0.0
23+ , aeson
29− , blaze-builder >= 0.4.0 && < 0.5.0
24+ , blaze-builder
30− , bytestring >= 0.10.0 && < 0.11.0
25+ , bytestring
31− , containers >= 0.5.0 && < 0.7.0
26+ , containers
32− , data-default-class >= 0.0.1 && < 0.2.0
27+ , data-default-class
33− , http-client >= 0.4.0 && < 0.7.0
28+ , http-client
34− , http-types >= 0.9 && < 0.13
29+ , http-types
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
51− , mtl >= 2.0.0 && < 3.0.0
30+ , mtl
52− , network >= 2.6.0
31+ , network >= 2.6
53− , text >= 1.0.0 && < 2.0.0
32+ , text
54− , time >= 1.5.0 && < 2.0.0
33+ , time
55− , scientific >= 0.3.0 && < 0.4.0
56− , tls >= 1.3.7 && < 1.6.0
34+ , tls >= 1.3.7
57− , unordered-containers >= 0.2.0 && < 0.3.0
35+ , unordered-containers
58− , x509 >= 1.6.0 && < 1.8.0
36+ , x509
59− , x509-store >= 1.6.0 && < 1.8.0
37+ , x509-store
60− , x509-system >= 1.6.0 && < 1.8.0
38+ , x509-system
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
68 default-language: Haskell2010
39 default-language: Haskell2010
69 ghc-options: -Wall -fno-warn-name-shadowing
40 ghc-options: -Wall -fno-warn-name-shadowing
70
41
@@ -73,7 +44,6 @@ test-suite docker-hs-tests
73 , bytestring
44 , bytestring
74 , connection
45 , connection
75 , docker
46 , docker
76− , directory
77 , aeson
47 , aeson
78 , containers
48 , containers
79 , unordered-containers
49 , unordered-containers
@@ -89,7 +59,6 @@ test-suite docker-hs-tests
89 , transformers
59 , transformers
90 , QuickCheck
60 , QuickCheck
91 , process
61 , process
92− , vector
93 type: exitcode-stdio-1.0
62 type: exitcode-stdio-1.0
94 main-is: tests.hs
63 main-is: tests.hs
95 hs-source-dirs: tests
64 hs-source-dirs: tests
examples/Example.hsdeleted−64
@@ -1,64 +0,0 @@
1−import Docker.Client
2−
3−runNginxContainer :: IO ContainerID
4−runNginxContainer = do
5− h <- defaultHttpHandler
6− runDockerT (defaultClientOpts, h) $
7− do let pb = PortBinding 80 TCP [HostPort "0.0.0.0" 8000]
8− let myCreateOpts = addPortBinding pb $ defaultCreateOpts "nginx:latest"
9− cid <- createContainer myCreateOpts (Just "myNginxContainer")
10− case cid of
11− Left err -> error $ show err
12− Right i -> do
13− _ <- startContainer defaultStartOpts i
14− return i
15−
16−stopNginxContainer :: ContainerID -> IO ()
17−stopNginxContainer cid = do
18− h <- defaultHttpHandler
19− runDockerT (defaultClientOpts, h) $
20− do r <- stopContainer DefaultTimeout cid
21− case r of
22− Left _ -> error "I failed to stop the container"
23− Right _ -> return ()
24−
25−runPostgresContainer :: IO ContainerID
26−runPostgresContainer = do
27− h <- defaultHttpHandler
28− runDockerT (defaultClientOpts, h) $
29− do let pb = PortBinding 5432 TCP [HostPort "0.0.0.0" 5432]
30− let b = Bind "/tmp" "/tmp" Nothing
31− let myCreateOpts = addBind b $ addPortBinding pb $ defaultCreateOpts "postgres:9.5"
32− cid <- createContainer myCreateOpts Nothing
33− case cid of
34− Left err -> error $ show err
35− Right i -> do
36− _ <- startContainer defaultStartOpts i
37− return i
38−
39−-- | Example of how we can start a database container while hosting it's
40−-- data in a data volume living inside another container.
41−runPostgresWithDataContainer :: IO ContainerID
42−runPostgresWithDataContainer = do
43− h <- defaultHttpHandler
44− runDockerT (defaultClientOpts, h) $
45− -- We use a dummy command like /bin/true because we don't want to start
46− -- the postgres database in the data container we just want it to
47− -- create a container filesystem for us.
48− do let dataOpts = setCmd "/bin/true" $ defaultCreateOpts "postgres:9.5"
49− cid <- createContainer dataOpts (Just "myDataContainer")
50− _ <-
51− case cid of
52− Left err -> error $ show err
53− Right i -> startContainer defaultStartOpts i
54− let pb = PortBinding 5432 TCP [HostPort "0.0.0.0" 5432]
55− -- Default permission is read-write if we don't specify anything
56− let vf = VolumeFrom "myDataContainer" Nothing
57− let myCreateOpts = addVolumeFrom vf $ addPortBinding pb $ defaultCreateOpts "postgres:9.5"
58− ccid <- createContainer myCreateOpts (Just "pgContainer")
59− case ccid of
60− Left err -> error $ show err
61− Right i -> do
62− _ <- startContainer defaultStartOpts i
63− return i
64−
scripts/hackage-docs.shdeleted−22
@@ -1,22 +0,0 @@
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+8−56
@@ -3,15 +3,15 @@
3
3
4{-|
4{-|
5Module : Docker.Client
5Module : Docker.Client
6−Copyright : (c) Deni Bertovic, 2014
6+Copyright : (c) Deni Bertovic, 2016
7License : BSD3
7License : BSD3
8Maintainer : deni@denibertovic.com
8Maintainer : deni@denibertovic.com
9Stability : experimental
9Stability : experimental
10Portability : POSIX
10Portability : POSIX
11
11
12−= Getting started
12+Getting started
13
13
14−Creating a container:
14+* Creating a container:
15
15
16We're going to create a nginx container and we're going to map port @80@ from within the container to port @8000@ on
16We're going to create a nginx container and we're going to map port @80@ from within the container to port @8000@ on
17the host.
17the host.
@@ -20,11 +20,9 @@ the host.
20import Docker.Client
20import Docker.Client
21
21
22runNginxContainer :: IO ContainerID
22runNginxContainer :: IO ContainerID
23−runNginxContainer = do
24− h <- defaultHttpHandler
25− runDockerT (defaultClientOpts, h) $ do
23+runNginxContainer = runDockerT (defaultClientOpts, defaultHttpHandler) $ do
26 let pb = PortBinding 80 TCP [HostPort "0.0.0.0" 8000]
24 let pb = PortBinding 80 TCP [HostPort "0.0.0.0" 8000]
27− let myCreateOpts = addPortBinding pb $ defaultCreateOpts "nginx:latest"
25+ let myCreateOpts = addPortBinding (defaultCreateOpts "nginx:latest") pb
28 cid <- createContainer myCreateOpts
26 cid <- createContainer myCreateOpts
29 case cid of
27 case cid of
30 Left err -> error $ show err
28 Left err -> error $ show err
@@ -44,9 +42,7 @@ Let's stop the container now:
44
42
45@
43@
46stopNginxContainer :: ContainerID -> IO ()
44stopNginxContainer :: ContainerID -> IO ()
47−stopNginxContainer cid = do
48− h <- defaultHttpHandler
49− runDockerT (defaultClientOpts, h) $ do
45+stopNginxContainer cid = runDockerT (defaultClientOpts, defaultHttpHandler) $ do
50 r <- stopContainer DefaultTimeout cid
46 r <- stopContainer DefaultTimeout cid
51 case r of
47 case r of
52 Left err -> error "I failed to stop the container"
48 Left err -> error "I failed to stop the container"
@@ -55,55 +51,11 @@ stopNginxContainer cid = do
55
51
56>>> stopNginxContainer cid
52>>> stopNginxContainer cid
57
53
58−Let's start a Postgres container by mapping the \/tmp directory from within the container to the
54+* Get Docker API Version:
59−\/tmp directory on the host. That way we make sure that the data we write to \/tmp in the container will
60−persist on the host file system.
61
55
62−@
63−runPostgresContainer :: IO ContainerID
64−runPostgresContainer = do
65− h <- defaultHttpHandler
66− runDockerT (defaultClientOpts, h) $ do
67− let pb = PortBinding 5432 TCP [HostPort "0.0.0.0" 5432]
68− let myCreateOpts = addBinds [Bind "\/tmp" "\/tmp" Nothing] $ addPortBinding pb $ defaultCreateOpts "postgres:9.5"
69− cid <- createContainer myCreateOpts
70− case cid of
71− Left err -> error $ show err
72− Right i -> do
73− _ <- startContainer defaultStartOpts i
74− return i
75−@
76−
77−= Get Docker API Version
78−
79−>>> h <- defaultHttpHandler
80−>>> runDockerT (defaultClientOpts, h) $ getDockerVersion
56+>>> runDockerT (defaultClientOpts, defaultHttpHandler) $ getDockerVersion
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"})
57Right (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"})
82
58
83−= Setup SSL Authentication
84−
85−Let's create a custom 'HttpHandler' that uses a client's certificate and private key for SSL authentication.
86−It also accepts a self-signed CA certificate which is specified via 'clientParamsSetCA'.
87−This handler can replace 'defaultHttpHandler' in the arguments to 'runDockerT'.
88−
89−@
90−let host = "domain.name"
91−let port = fromInteger 4000
92−let privKey = "path\/to\/private\/key"
93−let cert = "path\/to\/certificate"
94−let ca = "path\/to\/CA"
95−paramsE <- clientParamsWithClientAuthentication host port privKey cert
96−case paramsE of
97− Left err ->
98− error err
99− Right params' -> do
100− params <- clientParamsSetCA params' ca
101− settings <- HTTP.mkManagerSettings (TLSSettings params) Nothing
102− manager <- newManager settings
103− return $ httpHandler manager
104−@
105−
106−
107-}
59-}
108module Docker.Client (
60module Docker.Client (
109 -- * Client functions
61 -- * Client functions
src/Docker/Client/Api.hs+68−149
@@ -7,7 +7,6 @@ module Docker.Client.Api (
7 , createContainer
7 , createContainer
8 , startContainer
8 , startContainer
9 , stopContainer
9 , stopContainer
10− , waitContainer
11 , killContainer
10 , killContainer
12 , restartContainer
11 , restartContainer
13 , pauseContainer
12 , pauseContainer
@@ -15,213 +14,133 @@ module Docker.Client.Api (
15 , deleteContainer
14 , deleteContainer
16 , inspectContainer
15 , inspectContainer
17 , getContainerLogs
16 , getContainerLogs
18− , getContainerLogsStream
19 -- * Images
17 -- * Images
20 , listImages
18 , listImages
21− , deleteImage
22− , buildImageFromDockerfile
23− , pullImage
24− -- * Network
25− , createNetwork
26− , removeNetwork
27 -- * Other
19 -- * Other
28 , getDockerVersion
20 , getDockerVersion
29 ) where
21 ) where
30
22
31−import Control.Monad.Catch (MonadMask (..))
23+import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
32−import Control.Monad.IO.Class
33−import Control.Monad.Reader (ask, lift)
24+import Control.Monad.Reader (ask, lift)
34−import Data.Aeson (FromJSON, eitherDecode')
25+import Data.Aeson (FromJSON, eitherDecode')
35−import qualified Data.ByteString as BS
26+import qualified Data.ByteString.Lazy as BSL
36−import qualified Data.ByteString.Lazy as BSL
37−import Data.Conduit (Sink)
38−import qualified Data.Conduit.Binary as Conduit
39−import qualified Data.Text as T
27+import qualified Data.Text as Text
40−import qualified Data.Text as Text
41−import Network.HTTP.Client (responseStatus)
28+import Network.HTTP.Client (responseBody, responseStatus)
42−import Network.HTTP.Types (StdMethod (..))
29+import Network.HTTP.Types (StdMethod (..))
43−import System.Exit (ExitCode (..))
44
30
45import Docker.Client.Http
31import Docker.Client.Http
46import Docker.Client.Types
32import Docker.Client.Types
47−import Docker.Client.Utils
48
33
49−requestUnit :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())
34+requestUnit :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())
50−requestUnit verb endpoint = fmap (const ()) <$> requestHelper verb endpoint
35+requestUnit verb endpoint = const (Right ()) <$> requestHelper verb endpoint
51
36
52−requestHelper :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError BSL.ByteString)
37+requestHelper :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError Response)
53−requestHelper verb endpoint = requestHelper' verb endpoint Conduit.sinkLbs
38+requestHelper verb endpoint = runExceptT $ do
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
57− (opts, HttpHandler httpHandler) <- ask
39+ (opts, httpHandler) <- lift ask
58 case mkHttpRequest verb endpoint opts of
40 case mkHttpRequest verb endpoint opts of
59 Nothing ->
41 Nothing ->
60− return $ Left $ DockerInvalidRequest endpoint
42+ throwError $ DockerInvalidRequest endpoint
61 Just request -> do
43 Just request -> do
62− -- JP: Do we need runResourceT?
63− -- lift $ NHS.httpSink request $ \response ->
64− lift $ httpHandler request $ \response ->
44+ response <- ExceptT $ lift $ httpHandler request
45+
65− -- Check status code.
46+ -- Check status code.
66− let status = responseStatus response in
47+ let status = responseStatus response
48+ maybe (return ()) throwError $
67− case statusCodeToError endpoint status of
49+ statusCodeToError endpoint status
68− Just err ->
50+
69− return $ Left err
51+ return response
70− Nothing ->
52+
71− fmap Right sink
72−
73−parseResponse :: (FromJSON a, Monad m) => Either DockerError BSL.ByteString -> DockerT m (Either DockerError a)
53+parseResponse :: (FromJSON a, Monad m) => Either DockerError Response -> DockerT m (Either DockerError a)
74parseResponse (Left err) =
54parseResponse (Left err) =
75 return $ Left err
55 return $ Left err
76parseResponse (Right response) =
56parseResponse (Right response) =
77 -- Parse request body.
57 -- Parse request body.
78− case eitherDecode' response of
58+ case eitherDecode' $ responseBody response of
79 Left err ->
59 Left err ->
80 return $ Left $ DockerClientDecodeError $ Text.pack err
60 return $ Left $ DockerClientDecodeError $ Text.pack err
81 Right r ->
61 Right r ->
82 return $ Right r
62 return $ Right r
83
63
84-- | Gets the version of the docker engine remote API.
64-- | Gets the version of the docker engine remote API.
85−getDockerVersion :: forall m. (MonadIO m, MonadMask m) => DockerT m (Either DockerError DockerVersion)
65+getDockerVersion :: forall m. Monad m => DockerT m (Either DockerError DockerVersion)
86getDockerVersion = requestHelper GET VersionEndpoint >>= parseResponse
66getDockerVersion = requestHelper GET VersionEndpoint >>= parseResponse
87
67
88−-- | Lists all running docker containers. Pass in @'defaultListOpts' {all
68+-- | Lists all running docker containers. Pass in 'defaultListOpts' {all
89−-- = True}@ to get a list of stopped containers as well.
69+-- = True} to get a list of stopped containers as well.
90−listContainers :: forall m. (MonadIO m, MonadMask m) => ListOpts -> DockerT m (Either DockerError [Container])
70+listContainers :: forall m. Monad m => ListOpts -> DockerT m (Either DockerError [Container])
91listContainers opts = requestHelper GET (ListContainersEndpoint opts) >>= parseResponse
71listContainers opts = requestHelper GET (ListContainersEndpoint opts) >>= parseResponse
92
72
93-- | Lists all docker images.
73-- | Lists all docker images.
94−listImages :: forall m. (MonadIO m, MonadMask m) => ListOpts -> DockerT m (Either DockerError [Image])
74+listImages :: forall m. Monad m => ListOpts -> DockerT m (Either DockerError [Image])
95listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse
75listImages opts = requestHelper GET (ListImagesEndpoint opts) >>= parseResponse
96
76
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−
103−-- | Creates a docker container but does __not__ start it. See
77+-- | Creates a docker container but does *not* start it. See
104−-- 'CreateOpts' for a list of options and you can use 'defaultCreateOpts'
78+-- "CreateOpts" for a list of options and you can use 'defaultCreateOpts'
105-- for some sane defaults.
79-- for some sane defaults.
106−createContainer :: forall m. (MonadIO m, MonadMask m) => CreateOpts -> Maybe ContainerName -> DockerT m (Either DockerError ContainerID)
80+createContainer :: forall m. Monad m => CreateOpts -> DockerT m (Either DockerError ContainerID)
107−createContainer opts cn = requestHelper POST (CreateContainerEndpoint opts cn) >>= parseResponse
81+createContainer opts = requestHelper POST (CreateContainerEndpoint opts) >>= parseResponse
108
82
109−-- | Start a container from a given 'ContainerID' that we get from
83+-- | Start a container from a given "ContainerID" that we get from
110−-- 'createContainer'. See 'StartOpts' for a list of configuration options
84+-- 'createContainer'. See "StartOpts" for a list of configuration options
111-- for starting a container. Use 'defaultStartOpts' for sane defaults.
85-- for starting a container. Use 'defaultStartOpts' for sane defaults.
112−startContainer :: forall m. (MonadIO m, MonadMask m) => StartOpts -> ContainerID -> DockerT m (Either DockerError ())
86+startContainer :: forall m. Monad m => StartOpts -> ContainerID -> DockerT m (Either DockerError ())
113startContainer sopts cid = requestUnit POST $ StartContainerEndpoint sopts cid
87startContainer sopts cid = requestUnit POST $ StartContainerEndpoint sopts cid
114
88
115−-- | Attempts to stop a container with the given 'ContainerID' gracefully
89+-- | Attempts to stop a container with the given "ContainerID" gracefully
116-- (SIGTERM).
90-- (SIGTERM).
117−-- The docker daemon will wait for the given 'Timeout' and then send
91+-- The docker daemon will wait for the given "Tiemout" and then send
118-- a SIGKILL killing the container.
92-- a SIGKILL killing the container.
119−stopContainer :: forall m. (MonadIO m, MonadMask m) => Timeout -> ContainerID -> DockerT m (Either DockerError ())
93+stopContainer :: forall m. Monad m => Timeout -> ContainerID -> DockerT m (Either DockerError ())
120stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid
94stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid
121
95
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−
130−-- | Sends a 'Signal' to the container with the given 'ContainerID'. Same
96+-- | Sends a "Signal" to the container with the given "ContainerID". Same
131−-- as 'stopContainer' but you choose the signal directly.
97+-- as "stopContainer" but you choose the signal directly.
132−killContainer :: forall m. (MonadIO m, MonadMask m) => Signal -> ContainerID -> DockerT m (Either DockerError ())
98+killContainer :: forall m. Monad m => Signal -> ContainerID -> DockerT m (Either DockerError ())
133killContainer s cid = requestUnit POST $ KillContainerEndpoint s cid
99killContainer s cid = requestUnit POST $ KillContainerEndpoint s cid
134
100
135−-- | Restarts a container with the given 'ContainerID'.
101+-- | Restarts a container with the given "ContainerID".
136−restartContainer :: forall m. (MonadIO m, MonadMask m) => Timeout -> ContainerID -> DockerT m (Either DockerError ())
102+restartContainer :: forall m. Monad m => Timeout -> ContainerID -> DockerT m (Either DockerError ())
137restartContainer t cid = requestUnit POST $ RestartContainerEndpoint t cid
103restartContainer t cid = requestUnit POST $ RestartContainerEndpoint t cid
138
104
139−-- | Pauses a container with the given 'ContainerID'.
105+-- | Pauses a container with the given "ContainerID"
140−pauseContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ())
106+pauseContainer :: forall m. Monad m => ContainerID -> DockerT m (Either DockerError ())
141pauseContainer cid = requestUnit POST $ PauseContainerEndpoint cid
107pauseContainer cid = requestUnit POST $ PauseContainerEndpoint cid
142
108
143−-- | Unpauses a container with the given 'ContainerID'.
109+-- | Unpauses a container with the given "ContainerID".
144−unpauseContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ())
110+unpauseContainer :: forall m. Monad m => ContainerID -> DockerT m (Either DockerError ())
145unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid
111unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid
146
112
147−-- | Deletes a container with the given 'ContainerID'.
113+-- | Deletes a container with the given "ContainerID".
148−-- See "ContainerDeleteOpts" for options and use 'defaultContainerDeleteOpts' for sane
114+-- See "DeleteOpts" for options and use 'defaultDeleteOpts' for sane
149-- defaults.
115-- defaults.
150−deleteContainer :: forall m. (MonadIO m, MonadMask m) => ContainerDeleteOpts -> ContainerID -> DockerT m (Either DockerError ())
116+deleteContainer :: forall m. Monad m => DeleteOpts -> ContainerID -> DockerT m (Either DockerError ())
151deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid
117deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid
152
118
153−-- | Gets 'ContainerDetails' for a given 'ContainerID'.
119+-- | Gets "ContainerDetails" for a given "ContainerID".
154−inspectContainer :: forall m . (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ContainerDetails)
120+inspectContainer :: forall m . Monad m => ContainerID -> DockerT m (Either DockerError ContainerDetails)
155inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= parseResponse
121inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= parseResponse
156
122
157−-- | Get's container's logs for a given 'ContainerID'.
123+-- | Get's container's logs for a given "ContainerID".
158−-- This will only work with the 'JsonFile' 'LogDriverType' as the other driver types disable
124+-- This will only work with the "JsonFile" "LogDriverType" as the other driver types disable
159−-- this endpoint and it will return a 'DockerError'.
125+-- this endpoint and it will return a "DockerError".
160--
126--
161−-- See 'LogOpts' for options that you can pass and
127+-- See "LogOpts" for options that you can pass and
162-- 'defaultLogOpts' for sane defaults.
128-- 'defaultLogOpts' for sane defaults.
163--
129--
130+-- __NOTE__: Currently streaming logs is
164−-- __NOTE__: his function will fetch the entire log that the
131+-- not supported and this function will fetch the entire log that the
165-- container produced in the json-file on disk. Depending on the logging
132-- container produced in the json-file on disk. Depending on the logging
166-- setup of the process in your container this can be a significant amount
133-- setup of the process in your container this can be a significant amount
167-- which might block your application...so use with caution.
134-- which might block your application...so use with caution.
168--
135--
169−-- If you want to stream the logs from the container continuosly then use
170−-- 'getContainerLogsStream'
171−--
172−-- __NOTE__: It's recommended to use one of the other 'LogDriverType's available (like
136+-- The recommended method is to use one of the other "LogDriverType"'s available (like
173-- syslog) for creating your containers.
137-- syslog) for creating your containers.
174−getContainerLogs :: forall m. (MonadIO m, MonadMask m) => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString)
138+getContainerLogs :: forall m. Monad m => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString)
175−getContainerLogs logopts cid = requestHelper GET (ContainerLogsEndpoint logopts False cid)
139+getContainerLogs logopts cid = fmap responseBody <$> requestHelper GET (ContainerLogsEndpoint logopts False cid)
176−
140+
177−{-| Continuously gets the container's logs as a stream. Uses conduit.
141+-- TODO: Use http-conduit to output to a sink.
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−-}
191−getContainerLogsStream :: forall m b . (MonadIO m, MonadMask m) => LogOpts -> ContainerID -> Sink BS.ByteString m b -> DockerT m (Either DockerError b)
142+-- getContainerLogsStream :: forall m. Monad m => Sink BSL.ByteString m b -> LogOpts -> ContainerID -> DockerT m (Either DockerError b)
192−getContainerLogsStream logopts cid = requestHelper' GET (ContainerLogsEndpoint logopts True cid)
143+-- getContainerLogsStream sink logopts cid = runResourceT $ do
193−-- JP: Should the second (follow) argument be True? XXX
144+-- response <- http request manager
194−
145+-- responseBody response C.$$+- sink
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
227
146
src/Docker/Client/Http.hs+30−87
@@ -3,28 +3,21 @@
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
11−import Control.Monad.Reader (ReaderT (..), runReaderT)
6+import Control.Monad.Reader (ReaderT, runReaderT)
12import qualified Data.ByteString.Char8 as BSC
7import qualified Data.ByteString.Char8 as BSC
13import qualified Data.ByteString.Lazy as BL
8import qualified Data.ByteString.Lazy as BL
14−import Data.Conduit (Sink)
15import Data.Default.Class (def)
9import Data.Default.Class (def)
16import Data.Monoid ((<>))
10import Data.Monoid ((<>))
17import Data.Text.Encoding (encodeUtf8)
11import Data.Text.Encoding (encodeUtf8)
18import Data.X509 (CertificateChain (..))
12import Data.X509 (CertificateChain (..))
19import Data.X509.CertificateStore (makeCertificateStore)
13import Data.X509.CertificateStore (makeCertificateStore)
20import Data.X509.File (readKeyFile, readSignedObject)
14import Data.X509.File (readKeyFile, readSignedObject)
21−import Network.HTTP.Client (defaultManagerSettings,
15+import Network.HTTP.Client (defaultManagerSettings, httpLbs,
22 managerRawConnection, method,
16 managerRawConnection, method,
23− newManager, parseRequest,
17+ newManager, parseUrl,
24 requestBody, requestHeaders)
18 requestBody, requestHeaders)
25import qualified Network.HTTP.Client as HTTP
19import qualified Network.HTTP.Client as HTTP
26import Network.HTTP.Client.Internal (makeConnection)
20import Network.HTTP.Client.Internal (makeConnection)
27−import qualified Network.HTTP.Simple as NHS
28import Network.HTTP.Types (StdMethod, status101, status200,
21import Network.HTTP.Types (StdMethod, status101, status200,
29 status201, status204)
22 status201, status204)
30import Network.TLS (ClientHooks (..),
23import Network.TLS (ClientHooks (..),
@@ -34,7 +27,7 @@ import Network.TLS (ClientHooks (..),
34import Network.TLS.Extra (ciphersuite_strong)
27import Network.TLS.Extra (ciphersuite_strong)
35import System.X509 (getSystemCertificateStore)
28import System.X509 (getSystemCertificateStore)
36
29
37−import Control.Monad.Catch (try)
30+import Control.Exception (try)
38import Control.Monad.Except
31import Control.Monad.Except
39import Control.Monad.Reader.Class
32import Control.Monad.Reader.Class
40import Data.Text as T
33import Data.Text as T
@@ -45,22 +38,20 @@ import qualified Network.Socket.ByteString as SBS
45
38
46
39
47import Docker.Client.Internal (getEndpoint,
40import Docker.Client.Internal (getEndpoint,
48− getEndpointContentType,
49 getEndpointRequestBody)
41 getEndpointRequestBody)
50import Docker.Client.Types (DockerClientOpts, Endpoint (..),
42import Docker.Client.Types (DockerClientOpts, Endpoint (..),
51− apiVer, baseUrl)
43+ baseUrl)
52
44
53type Request = HTTP.Request
45type Request = HTTP.Request
54type Response = HTTP.Response BL.ByteString
46type Response = HTTP.Response BL.ByteString
55type HttpVerb = StdMethod
47type HttpVerb = StdMethod
56−newtype HttpHandler m = HttpHandler (forall a . Request -> (HTTP.Response () -> Sink BSC.ByteString m (Either DockerError a)) -> m (Either DockerError a))
48+type HttpHandler m = Request -> m (Either DockerError Response)
57
49
58−data DockerError = DockerConnectionError NHS.HttpException
50+data DockerError = DockerConnectionError
59 | DockerInvalidRequest Endpoint
51 | DockerInvalidRequest Endpoint
60− | DockerClientError Text
61 | DockerClientDecodeError Text -- ^ Could not parse the response from the Docker endpoint.
52 | DockerClientDecodeError Text -- ^ Could not parse the response from the Docker endpoint.
62 | DockerInvalidStatusCode HTTP.Status -- ^ Invalid exit code received from Docker endpoint.
53 | DockerInvalidStatusCode HTTP.Status -- ^ Invalid exit code received from Docker endpoint.
63− | GenericDockerError Text deriving (Show, Typeable)
54+ | GenericDockerError Text deriving (Eq, Show, Typeable)
64
55
65newtype DockerT m a = DockerT {
56newtype DockerT m a = DockerT {
66 unDockerT :: Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
57 unDockerT :: Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a
@@ -84,9 +75,6 @@ instance MonadTrans DockerT where
84instance MonadIO m => MonadIO (DockerT m) where
75instance MonadIO m => MonadIO (DockerT m) where
85 liftIO = lift . liftIO
76 liftIO = lift . liftIO
86
77
87−-- instance MonadBase IO m => MonadBase IO (DockerT m) where
88−-- liftBase = liftBaseDefault
89−
90runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
78runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a
91runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
79runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
92
80
@@ -96,41 +84,28 @@ runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)
96-- benefit from testing that on all of our Endpoints
84-- benefit from testing that on all of our Endpoints
97mkHttpRequest :: HttpVerb -> Endpoint -> DockerClientOpts -> Maybe Request
85mkHttpRequest :: HttpVerb -> Endpoint -> DockerClientOpts -> Maybe Request
98mkHttpRequest verb e opts = request
86mkHttpRequest verb e opts = request
99− where fullE = T.unpack (baseUrl opts) ++ T.unpack (getEndpoint (apiVer opts) e)
87+ where fullE = T.unpack (baseUrl opts) ++ T.unpack (getEndpoint e)
100− initialR = parseRequest fullE
88+ initialR = parseUrl fullE
101 request' = case initialR of
89 request' = case initialR of
102 Just ir ->
90 Just ir ->
103 return $ ir {method = (encodeUtf8 . T.pack $ show verb),
91 return $ ir {method = (encodeUtf8 . T.pack $ show verb),
104− requestHeaders = [("Content-Type", (getEndpointContentType e))]}
92+ requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}
105 Nothing -> Nothing
93 Nothing -> Nothing
106− request = (\r -> maybe r (\body -> r {requestBody = body, -- This will either be a HTTP.RequestBodyLBS or HTTP.RequestBodySourceChunked for the build endpoint
94+ request = (\r -> maybe r (\body -> r {requestBody = HTTP.RequestBodyLBS body,
107 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'
95 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'
108 -- Note: Do we need to set length header?
96 -- Note: Do we need to set length header?
109
97
110−defaultHttpHandler :: (
98+defaultHttpHandler :: MonadIO m => HttpHandler m
111−#if MIN_VERSION_http_conduit(2,3,0)
112− MonadUnliftIO m,
113−#endif
114− MonadIO m, MonadMask m) => m (HttpHandler m)
115−defaultHttpHandler = do
99+defaultHttpHandler request = do
116 manager <- liftIO $ newManager defaultManagerSettings
100 manager <- liftIO $ newManager defaultManagerSettings
117− return $ httpHandler manager
101+ httpHandler manager request
118−
102+
119−httpHandler :: (
120−#if MIN_VERSION_http_conduit(2,3,0)
121− MonadUnliftIO m,
122−#endif
123− MonadIO m, MonadMask m) => HTTP.Manager -> HttpHandler m
103+httpHandler :: MonadIO m => HTTP.Manager -> HttpHandler m
124−httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..
104+httpHandler manager request = liftIO $ do
125− let request = NHS.setRequestManager manager request'
126− try (NHS.httpSink request sink) >>= \res -> case res of
105+ try (httpLbs request manager) >>= \res -> case res of
127− Right res -> return res
106+ Right res -> return $ Right res
128−#if MIN_VERSION_http_client(0,5,0)
129− Left e@(HTTP.HttpExceptionRequest _ HTTP.ConnectionFailure{}) -> return $ Left $ DockerConnectionError e
130−#else
131− Left e@HTTP.FailedConnectionException{} -> return $ Left $ DockerConnectionError e
107+ Left HTTP.FailedConnectionException{} -> return $ Left DockerConnectionError
132− Left e@HTTP.FailedConnectionException2{} -> return $ Left $ DockerConnectionError e
108+ Left HTTP.FailedConnectionException2{} -> return $ Left DockerConnectionError
133−#endif
134 Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
109 Left e -> return $ Left $ GenericDockerError (T.pack $ show e)
135
110
136-- | Connect to a unix domain socket (the default docker socket is
111-- | Connect to a unix domain socket (the default docker socket is
@@ -138,17 +113,13 @@ httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..
138--
113--
139-- Docker seems to ignore the hostname in requests sent over unix domain
114-- Docker seems to ignore the hostname in requests sent over unix domain
140-- sockets (and the port obviously doesn't matter either)
115-- 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
145− MonadIO m, MonadMask m) => FilePath -- ^ The socket to connect to
116+unixHttpHandler :: MonadIO m => FilePath -- ^ The socket to connect to
146− -> m (HttpHandler m)
117+ -> HttpHandler m
147−unixHttpHandler fp = do
118+unixHttpHandler fp request = do
148 let mSettings = defaultManagerSettings
119 let mSettings = defaultManagerSettings
149 { managerRawConnection = return $ openUnixSocket fp}
120 { managerRawConnection = return $ openUnixSocket fp}
150 manager <- liftIO $ newManager mSettings
121 manager <- liftIO $ newManager mSettings
151− return $ httpHandler manager
122+ httpHandler manager request
152
123
153 where
124 where
154 openUnixSocket filePath _ _ _ = do
125 openUnixSocket filePath _ _ _ = do
@@ -156,7 +127,7 @@ unixHttpHandler fp = do
156 S.connect s (S.SockAddrUnix filePath)
127 S.connect s (S.SockAddrUnix filePath)
157 makeConnection (SBS.recv s 8096)
128 makeConnection (SBS.recv s 8096)
158 (SBS.sendAll s)
129 (SBS.sendAll s)
159− (S.close s)
130+ (S.sClose s)
160
131
161-- TODO:
132-- TODO:
162-- Move this to http-client-tls or network?
133-- Move this to http-client-tls or network?
@@ -208,7 +179,7 @@ statusCodeToError (ListImagesEndpoint _) st =
208 Nothing
179 Nothing
209 else
180 else
210 Just $ DockerInvalidStatusCode st
181 Just $ DockerInvalidStatusCode st
211−statusCodeToError (CreateContainerEndpoint _ _) st =
182+statusCodeToError (CreateContainerEndpoint _) st =
212 if st == status201 then
183 if st == status201 then
213 Nothing
184 Nothing
214 else
185 else
@@ -223,11 +194,6 @@ statusCodeToError (StopContainerEndpoint _ _) st =
223 Nothing
194 Nothing
224 else
195 else
225 Just $ DockerInvalidStatusCode st
196 Just $ DockerInvalidStatusCode st
226−statusCodeToError (WaitContainerEndpoint _) st =
227− if st == status200 then
228− Nothing
229− else
230− Just $ DockerInvalidStatusCode st
231statusCodeToError (KillContainerEndpoint _ _) st =
197statusCodeToError (KillContainerEndpoint _ _) st =
232 if st == status204 then
198 if st == status204 then
233 Nothing
199 Nothing
@@ -263,28 +229,5 @@ statusCodeToError (InspectContainerEndpoint _) st =
263 Nothing
229 Nothing
264 else
230 else
265 Just $ DockerInvalidStatusCode st
231 Just $ DockerInvalidStatusCode st
266−statusCodeToError (BuildImageEndpoint _ _) st =
232+
267− if st == status200 then
233+
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+25−60
@@ -1,17 +1,14 @@
1module Docker.Client.Internal where
1module Docker.Client.Internal where
2
2
3+
3import Blaze.ByteString.Builder (toByteString)
4import Blaze.ByteString.Builder (toByteString)
4import qualified Data.Aeson as JSON
5import qualified Data.Aeson as JSON
5import Data.ByteString (ByteString)
6import Data.ByteString (ByteString)
6−import qualified Data.ByteString.Char8 as BSC
7+import qualified Data.ByteString.Lazy as BSL
7−import qualified Data.Conduit.Binary as CB
8−import qualified Data.Text as T
8+import 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)
12import Network.HTTP.Types (Query, encodePath,
10import Network.HTTP.Types (Query, encodePath,
13 encodePathSegments)
11 encodePathSegments)
14−import Prelude hiding (all)
15
12
16import Docker.Client.Types
13import Docker.Client.Types
17
14
@@ -25,68 +22,48 @@ encodeURLWithQuery ps q = decodeUtf8 $ toByteString $ encodePath ps q
25encodeQ :: String -> ByteString
22encodeQ :: String -> ByteString
26encodeQ = encodeUtf8 . T.pack
23encodeQ = encodeUtf8 . T.pack
27
24
28−getEndpoint :: ApiVersion -> Endpoint -> T.Text
25+getEndpoint :: Endpoint -> T.Text
29−getEndpoint v VersionEndpoint = encodeURL [v, "version"]
26+getEndpoint VersionEndpoint = encodeURL ["version"]
30−getEndpoint v (ListContainersEndpoint (ListOpts all)) = encodeURLWithQuery [v, "containers", "json"] [("all", Just (encodeQ $ show all))]
27+getEndpoint (ListContainersEndpoint _) = encodeURL ["containers", "json"] -- Make use of lsOpts here
31−getEndpoint v (ListImagesEndpoint _) = encodeURL [v, "images", "json"] -- Make use of lsOpts here
28+getEndpoint (ListImagesEndpoint _) = encodeURL ["images", "json"] -- Make use of lsOpts here
32−getEndpoint v (CreateContainerEndpoint _ cn) = case cn of
29+getEndpoint (CreateContainerEndpoint _) = encodeURL ["containers", "create"]
33− Just cn -> encodeURLWithQuery [v, "containers", "create"] [("name", Just (encodeQ $ T.unpack cn))]
34− Nothing -> encodeURL [v, "containers", "create"]
35−getEndpoint v (StartContainerEndpoint startOpts cid) = encodeURLWithQuery [v, "containers", fromContainerID cid, "start"] query
30+getEndpoint (StartContainerEndpoint startOpts cid) = encodeURLWithQuery ["containers", fromContainerID cid, "start"] query
36 where query = case (detachKeys startOpts) of
31 where query = case (detachKeys startOpts) of
37 WithCtrl c -> [("detachKeys", Just (encodeQ $ ctrl ++ [c]))]
32 WithCtrl c -> [("detachKeys", Just (encodeQ $ ctrl ++ [c]))]
38 WithoutCtrl c -> [("detachKeys", Just (encodeQ [c]))]
33 WithoutCtrl c -> [("detachKeys", Just (encodeQ [c]))]
39 DefaultDetachKey -> []
34 DefaultDetachKey -> []
40 ctrl = ['c', 't', 'r', 'l', '-']
35 ctrl = ['c', 't', 'r', 'l', '-']
41−getEndpoint v (StopContainerEndpoint t cid) = encodeURLWithQuery [v, "containers", fromContainerID cid, "stop"] query
36+getEndpoint (StopContainerEndpoint t cid) = encodeURLWithQuery ["containers", fromContainerID cid, "stop"] query
42 where query = case t of
37 where query = case t of
43− Timeout x -> [("t", Just (encodeQ $ show x))]
38+ Timeout x -> [("t", Just (encodeQ $ show x))]
44 DefaultTimeout -> []
39 DefaultTimeout -> []
45−getEndpoint v (WaitContainerEndpoint cid) = encodeURL [v, "containers", fromContainerID cid, "wait"]
46−getEndpoint v (KillContainerEndpoint s cid) = encodeURLWithQuery [v, "containers", fromContainerID cid, "kill"] query
40+getEndpoint (KillContainerEndpoint s cid) = encodeURLWithQuery ["containers", fromContainerID cid, "kill"] query
47 where query = case s of
41 where query = case s of
48 SIG x -> [("signal", Just (encodeQ $ show x))]
42 SIG x -> [("signal", Just (encodeQ $ show x))]
49− _ -> [("signal", Just (encodeQ $ show s))]
43+ _ -> [("signal", Just (encodeQ $ show s))]
50−getEndpoint v (RestartContainerEndpoint t cid) = encodeURLWithQuery [v, "containers", fromContainerID cid, "restart"] query
44+getEndpoint (RestartContainerEndpoint t cid) = encodeURLWithQuery ["containers", fromContainerID cid, "restart"] query
51 where query = case t of
45 where query = case t of
52− Timeout x -> [("t", Just (encodeQ $ show x))]
46+ Timeout x -> [("t", Just (encodeQ $ show x))]
53 DefaultTimeout -> []
47 DefaultTimeout -> []
54−getEndpoint v (PauseContainerEndpoint cid) = encodeURL [v, "containers", fromContainerID cid, "pause"]
48+getEndpoint (PauseContainerEndpoint cid) = encodeURL ["containers", fromContainerID cid, "pause"]
55−getEndpoint v (UnpauseContainerEndpoint cid) = encodeURL [v, "containers", fromContainerID cid, "unpause"]
49+getEndpoint (UnpauseContainerEndpoint cid) = encodeURL ["containers", fromContainerID cid, "unpause"]
56-- Make use of since/timestamps/tail logopts here instead of ignoreing them
50-- Make use of since/timestamps/tail logopts here instead of ignoreing them
57−getEndpoint v (ContainerLogsEndpoint (LogOpts stdout stderr _ _ _) follow cid) =
51+getEndpoint (ContainerLogsEndpoint (LogOpts stdout stderr _ _ _) follow cid) =
58− encodeURLWithQuery [v, "containers", fromContainerID cid, "logs"] query
52+ encodeURLWithQuery ["containers", fromContainerID cid, "logs"] query
59 where query = [("stdout", Just (encodeQ $ show stdout)), ("stderr", Just (encodeQ $ show stderr)), ("follow", Just (encodeQ $ show follow))]
53 where query = [("stdout", Just (encodeQ $ show stdout)), ("stderr", Just (encodeQ $ show stderr)), ("follow", Just (encodeQ $ show follow))]
60−getEndpoint v (DeleteContainerEndpoint (ContainerDeleteOpts removeVolumes force) cid) =
54+getEndpoint (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =
61− encodeURLWithQuery [v, "containers", fromContainerID cid] query
55+ encodeURLWithQuery ["containers", fromContainerID cid] query
62 where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))]
56 where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))]
63−getEndpoint v (InspectContainerEndpoint cid) =
57+getEndpoint (InspectContainerEndpoint cid) =
64− encodeURLWithQuery [v, "containers", fromContainerID cid, "json"] []
58+ encodeURLWithQuery ["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]
81
59
82−getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody
60+getEndpointRequestBody :: Endpoint -> Maybe BSL.ByteString
83getEndpointRequestBody VersionEndpoint = Nothing
61getEndpointRequestBody VersionEndpoint = Nothing
84getEndpointRequestBody (ListContainersEndpoint _) = Nothing
62getEndpointRequestBody (ListContainersEndpoint _) = Nothing
85getEndpointRequestBody (ListImagesEndpoint _) = Nothing
63getEndpointRequestBody (ListImagesEndpoint _) = Nothing
86−getEndpointRequestBody (CreateContainerEndpoint opts _) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)
64+getEndpointRequestBody (CreateContainerEndpoint opts) = Just $ JSON.encode opts
87getEndpointRequestBody (StartContainerEndpoint _ _) = Nothing
65getEndpointRequestBody (StartContainerEndpoint _ _) = Nothing
88getEndpointRequestBody (StopContainerEndpoint _ _) = Nothing
66getEndpointRequestBody (StopContainerEndpoint _ _) = Nothing
89−getEndpointRequestBody (WaitContainerEndpoint _) = Nothing
90getEndpointRequestBody (KillContainerEndpoint _ _) = Nothing
67getEndpointRequestBody (KillContainerEndpoint _ _) = Nothing
91getEndpointRequestBody (RestartContainerEndpoint _ _) = Nothing
68getEndpointRequestBody (RestartContainerEndpoint _ _) = Nothing
92getEndpointRequestBody (PauseContainerEndpoint _) = Nothing
69getEndpointRequestBody (PauseContainerEndpoint _) = Nothing
@@ -94,15 +71,3 @@ getEndpointRequestBody (UnpauseContainerEndpoint _) = Nothing
94getEndpointRequestBody (ContainerLogsEndpoint _ _ _) = Nothing
71getEndpointRequestBody (ContainerLogsEndpoint _ _ _) = Nothing
95getEndpointRequestBody (DeleteContainerEndpoint _ _) = Nothing
72getEndpointRequestBody (DeleteContainerEndpoint _ _) = Nothing
96getEndpointRequestBody (InspectContainerEndpoint _) = Nothing
73getEndpointRequestBody (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+233−577
@@ -11,11 +11,7 @@ module Docker.Client.Types (
11 , ImageID
11 , ImageID
12 , fromImageID
12 , fromImageID
13 , toImageID
13 , toImageID
14− , NetworkID
15− , fromNetworkID
16− , toNetworkID
17 , Timeout(..)
14 , Timeout(..)
18− , StatusCode(..)
19 , Signal(..)
15 , Signal(..)
20 , ContainerDetails(..)
16 , ContainerDetails(..)
21 , DockerClientOpts(..)
17 , DockerClientOpts(..)
@@ -26,48 +22,41 @@ module Docker.Client.Types (
26 , ContainerPortInfo(..)
22 , ContainerPortInfo(..)
27 , Container(..)
23 , Container(..)
28 , ContainerState(..)
24 , ContainerState(..)
29− , State(..)
25+ , Status(..)
30 , Digest
26 , Digest
31− , Label(..)
27+ , Labels(..)
32 , Tag
28 , Tag
33 , Image(..)
29 , Image(..)
34− , Entrypoint(..)
35 , dropImagePrefix
30 , dropImagePrefix
36 , CreateOpts(..)
31 , CreateOpts(..)
37− , BuildOpts(..)
38− , defaultBuildOpts
39 , defaultCreateOpts
32 , defaultCreateOpts
40 , DetachKeys(..)
33 , DetachKeys(..)
41 , StartOpts(..)
34 , StartOpts(..)
42 , defaultStartOpts
35 , defaultStartOpts
43− , ContainerDeleteOpts(..)
36+ , DeleteOpts(..)
44− , defaultContainerDeleteOpts
37+ , defaultDeleteOpts
45− , ImageDeleteOpts(..)
46− , defaultImageDeleteOpts
47 , Timestamp
38 , Timestamp
48 , TailLogOpt(..)
39 , TailLogOpt(..)
49 , LogOpts(..)
40 , LogOpts(..)
50 , defaultLogOpts
41 , defaultLogOpts
51− , CreateNetworkOpts(..)
52− , defaultCreateNetworkOpts
53 , VolumePermission(..)
42 , VolumePermission(..)
54− , Bind(..)
55 , Volume(..)
43 , Volume(..)
56 , Device(..)
44 , Device(..)
57 , ContainerName
45 , ContainerName
58 , VolumeFrom(..)
46 , VolumeFrom(..)
59 , Link(..)
47 , Link(..)
60 , LogDriverType(..)
48 , LogDriverType(..)
61− , LogDriverOption(..)
49+ , LogDriverOptions(..)
62 , LogDriverConfig(..)
50 , LogDriverConfig(..)
63 , NetworkMode(..)
51 , NetworkMode(..)
64 , PortType(..)
52 , PortType(..)
65-- , NetworkInterface(..)
53-- , NetworkInterface(..)
66− , Network(..)
54+ , Networks(..)
67 , NetworkSettings(..)
55 , NetworkSettings(..)
68 , NetworkOptions(..)
56 , NetworkOptions(..)
69 , Mount(..)
57 , Mount(..)
70 , PortBinding(..)
58 , PortBinding(..)
59+ , PortBindings(..)
71 , HostPort(..)
60 , HostPort(..)
72 , RetryCount
61 , RetryCount
73 , RestartPolicy(..)
62 , RestartPolicy(..)
@@ -75,8 +64,6 @@ module Docker.Client.Types (
75 , UTSMode(..)
64 , UTSMode(..)
76 , HostConfig(..)
65 , HostConfig(..)
77 , defaultHostConfig
66 , defaultHostConfig
78− , NetworkingConfig(..)
79− , EndpointConfig(..)
80 , Ulimit(..)
67 , Ulimit(..)
81 , ContainerResources(..)
68 , ContainerResources(..)
82 , defaultContainerResources
69 , defaultContainerResources
@@ -86,18 +73,10 @@ module Docker.Client.Types (
86 , EnvVar(..)
73 , EnvVar(..)
87 , ContainerConfig(..)
74 , ContainerConfig(..)
88 , defaultContainerConfig
75 , defaultContainerConfig
89− , ExposedPort(..)
76+ , ExposedPorts(..)
90 , DeviceWeight(..)
77 , DeviceWeight(..)
91 , DeviceRate(..)
78 , DeviceRate(..)
92 , addPortBinding
79 , addPortBinding
93− , addExposedPort
94− , addBind
95− , setCmd
96− , addLink
97− , addVolume
98− , addVolumeFrom
99− , MemoryConstraint(..)
100− , MemoryConstraintSize(..)
101 ) where
80 ) where
102
81
103import Data.Aeson (FromJSON, ToJSON, genericParseJSON,
82import Data.Aeson (FromJSON, ToJSON, genericParseJSON,
@@ -107,57 +86,40 @@ import qualified Data.Aeson as JSON
107import Data.Aeson.Types (defaultOptions, fieldLabelModifier)
86import Data.Aeson.Types (defaultOptions, fieldLabelModifier)
108import Data.Char (isAlphaNum, toUpper)
87import Data.Char (isAlphaNum, toUpper)
109import qualified Data.HashMap.Strict as HM
88import qualified Data.HashMap.Strict as HM
89+import qualified Data.Map as M
110import Data.Monoid ((<>))
90import Data.Monoid ((<>))
111−import Data.Scientific (floatingOrInteger)
112import Data.Text (Text)
91import Data.Text (Text)
113import qualified Data.Text as T
92import qualified Data.Text as T
114import Data.Time.Clock (UTCTime)
93import Data.Time.Clock (UTCTime)
115−import qualified Data.Vector as V
116import GHC.Generics (Generic)
94import GHC.Generics (Generic)
117import Prelude hiding (all, tail)
95import Prelude hiding (all, tail)
118import Text.Read (readMaybe)
96import Text.Read (readMaybe)
119
97
120−-- | List of Docker Engine API endpoints
121data Endpoint =
98data Endpoint =
122 VersionEndpoint
99 VersionEndpoint
123 | ListContainersEndpoint ListOpts
100 | ListContainersEndpoint ListOpts
124 | ListImagesEndpoint ListOpts
101 | ListImagesEndpoint ListOpts
125− | CreateContainerEndpoint CreateOpts (Maybe ContainerName)
102+ | CreateContainerEndpoint CreateOpts
126 | StartContainerEndpoint StartOpts ContainerID
103 | StartContainerEndpoint StartOpts ContainerID
127 | StopContainerEndpoint Timeout ContainerID
104 | StopContainerEndpoint Timeout ContainerID
128− | WaitContainerEndpoint ContainerID
129 | KillContainerEndpoint Signal ContainerID
105 | KillContainerEndpoint Signal ContainerID
130 | RestartContainerEndpoint Timeout ContainerID
106 | RestartContainerEndpoint Timeout ContainerID
131 | PauseContainerEndpoint ContainerID
107 | PauseContainerEndpoint ContainerID
132 | UnpauseContainerEndpoint ContainerID
108 | UnpauseContainerEndpoint ContainerID
133 | ContainerLogsEndpoint LogOpts Bool ContainerID -- ^ Second argument (Bool) is whether to follow which is currently hardcoded to False.
109 | ContainerLogsEndpoint LogOpts Bool ContainerID -- ^ Second argument (Bool) is whether to follow which is currently hardcoded to False.
134 -- See note in 'Docker.Client.Api.getContainerLogs' for explanation why.
110 -- See note in 'Docker.Client.Api.getContainerLogs' for explanation why.
135− | DeleteContainerEndpoint ContainerDeleteOpts ContainerID
111+ | DeleteContainerEndpoint DeleteOpts ContainerID
136 | InspectContainerEndpoint ContainerID
112 | 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
142 deriving (Eq, Show)
113 deriving (Eq, Show)
143
114
144−-- | We should newtype this
145type URL = Text
115type URL = Text
146−
147−-- | We should newtype this
148type ApiVersion = Text
116type ApiVersion = Text
149−
150−
151−-- | ID of a contianer
152newtype ContainerID = ContainerID Text
117newtype ContainerID = ContainerID Text
153 deriving (Eq, Show)
118 deriving (Eq, Show)
154
119
155−-- | Used for extracting the id of the container from the newtype
156fromContainerID :: ContainerID -> Text
120fromContainerID :: ContainerID -> Text
157fromContainerID (ContainerID t) = t
121fromContainerID (ContainerID t) = t
158
122
159−-- | Used for parsing a Text value into a ContainerID. We apply some basic
160−-- validation here.
161toContainerID :: Text -> Maybe ContainerID
123toContainerID :: Text -> Maybe ContainerID
162toContainerID t =
124toContainerID t =
163 if T.all (\c -> isAlphaNum c || c == ':') t then -- Note: Can we improve this whitelist?
125 if T.all (\c -> isAlphaNum c || c == ':') t then -- Note: Can we improve this whitelist?
@@ -165,16 +127,12 @@ toContainerID t =
165 else
127 else
166 Nothing
128 Nothing
167
129
168−-- ID of an image.
169newtype ImageID = ImageID Text
130newtype ImageID = ImageID Text
170 deriving (Eq, Show)
131 deriving (Eq, Show)
171
132
172−-- | Used for extracting the id of the image from the newtype.
173fromImageID :: ImageID -> Text
133fromImageID :: ImageID -> Text
174fromImageID (ImageID t) = t
134fromImageID (ImageID t) = t
175
135
176−-- | Helper function used for parsing a Text value into an ImageID. For now
177−-- just basic validation is used.
178toImageID :: Text -> Maybe ImageID
136toImageID :: Text -> Maybe ImageID
179toImageID t =
137toImageID t =
180 if T.all (\c -> isAlphaNum c || c == ':') t then -- Note: Can we improve this whitelist?
138 if T.all (\c -> isAlphaNum c || c == ':') t then -- Note: Can we improve this whitelist?
@@ -182,26 +140,9 @@ toImageID t =
182 else
140 else
183 Nothing
141 Nothing
184
142
185−-- | Timeout used for stopping a container. DefaultTimeout is 10 seconds.
186data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show)
143data Timeout = Timeout Integer | DefaultTimeout deriving (Eq, Show)
187
144
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−
202-- TODO: Add more Signals or use an existing lib
145-- TODO: Add more Signals or use an existing lib
203−-- | Signal used for sending to the process running in the container.
204−-- The default signal is SIGTERM.
205data Signal = SIGHUP
146data Signal = SIGHUP
206 | SIGINT
147 | SIGINT
207 | SIGQUIT
148 | SIGQUIT
@@ -213,16 +154,16 @@ data Signal = SIGHUP
213
154
214instance FromJSON Signal where
155instance FromJSON Signal where
215 parseJSON (JSON.String "SIGTERM") = return SIGTERM
156 parseJSON (JSON.String "SIGTERM") = return SIGTERM
216− parseJSON (JSON.String "SIGHUP") = return SIGHUP -- Note: Guessing on the string values for these.
157+ parseJSON (JSON.String "SIGHUP") = return SIGHUP -- Note: Guessing on the string values for these.
217− parseJSON (JSON.String "SIGINT") = return SIGINT
158+ parseJSON (JSON.String "SIGINT") = return SIGINT
218 parseJSON (JSON.String "SIGQUIT") = return SIGQUIT
159 parseJSON (JSON.String "SIGQUIT") = return SIGQUIT
219 parseJSON (JSON.String "SIGSTOP") = return SIGSTOP
160 parseJSON (JSON.String "SIGSTOP") = return SIGSTOP
220 parseJSON (JSON.String "SIGUSR1") = return SIGUSR1
161 parseJSON (JSON.String "SIGUSR1") = return SIGUSR1
221− parseJSON _ = fail "Unknown Signal"
162+ parseJSON _ = fail "Unknown Signal"
222
163
223instance ToJSON Signal where
164instance ToJSON Signal where
224− toJSON SIGHUP = "SIGHUP"
165+ toJSON SIGHUP = "SIGHUP"
225− toJSON SIGINT = "SIGINT"
166+ toJSON SIGINT = "SIGINT"
226 toJSON SIGQUIT = "SIGQUIT"
167 toJSON SIGQUIT = "SIGQUIT"
227 toJSON SIGSTOP = "SIGSTOP"
168 toJSON SIGSTOP = "SIGSTOP"
228 toJSON SIGTERM = "SIGTERM"
169 toJSON SIGTERM = "SIGTERM"
@@ -250,19 +191,17 @@ data ContainerDetails = ContainerDetails {
250 , processLabel :: Text
191 , processLabel :: Text
251 , resolveConfPath :: FilePath
192 , resolveConfPath :: FilePath
252 , restartCount :: Int
193 , restartCount :: Int
253− , containerDetailsState :: ContainerState
194+ , state :: ContainerState
254 , mounts :: [Mount]
195 , mounts :: [Mount]
255 }
196 }
256 deriving (Eq, Show, Generic)
197 deriving (Eq, Show, Generic)
257
198
258−-- | Data type used for parsing the mount information from a container
259−-- list.
260data Mount = Mount {
199data Mount = Mount {
261− mountName :: Maybe Text -- this is optional
200+ mountName :: Text
262 , mountSource :: FilePath
201 , mountSource :: FilePath
263 , mountDestination :: FilePath
202 , mountDestination :: FilePath
264− , mountDriver :: Maybe Text
203+ , mountDriver :: Text
265− -- , mountMode :: Maybe VolumePermission -- apparently this can be null
204+ , mountMode :: Text -- Note: Improve this?
266 , mountRW :: Bool
205 , mountRW :: Bool
267 , mountPropogation :: Text
206 , mountPropogation :: Text
268 }
207 }
@@ -270,18 +209,16 @@ data Mount = Mount {
270
209
271instance FromJSON Mount where
210instance FromJSON Mount where
272 parseJSON (JSON.Object o) = do
211 parseJSON (JSON.Object o) = do
273− name <- o .:? "Name"
212+ name <- o .: "Name"
274 src <- o .: "Source"
213 src <- o .: "Source"
275 dest <- o .: "Destination"
214 dest <- o .: "Destination"
276− driver <- o .:? "Driver"
215+ driver <- o .: "Driver"
277− -- mode <- o .: "Mode"
216+ mode <- o .: "Mode"
278 rw <- o .: "RW"
217 rw <- o .: "RW"
279 prop <- o .: "Propagation"
218 prop <- o .: "Propagation"
280− return $ Mount name src dest driver rw prop
219+ return $ Mount name src dest driver mode rw prop
281 parseJSON _ = fail "Mount is not an object"
220 parseJSON _ = fail "Mount is not an object"
282
221
283−-- | Data type used for parsing the container state from a list of
284−-- containers.
285data ContainerState = ContainerState {
222data ContainerState = ContainerState {
286 containerError :: Text
223 containerError :: Text
287 , exitCode :: Int
224 , exitCode :: Int
@@ -293,7 +230,7 @@ data ContainerState = ContainerState {
293 , restarting :: Bool
230 , restarting :: Bool
294 , running :: Bool
231 , running :: Bool
295 , startedAt :: UTCTime
232 , startedAt :: UTCTime
296− , state :: State
233+ , status :: Status
297 }
234 }
298 deriving (Eq, Show, Generic)
235 deriving (Eq, Show, Generic)
299
236
@@ -313,30 +250,23 @@ instance FromJSON ContainerState where
313 return $ ContainerState err exit finished oomKilled dead paused pid restarting running started st
250 return $ ContainerState err exit finished oomKilled dead paused pid restarting running started st
314 parseJSON _ = fail "ContainerState is not an object"
251 parseJSON _ = fail "ContainerState is not an object"
315
252
316−
317−-- | Client options used to configure the remote engine we're talking to
318data DockerClientOpts = DockerClientOpts {
253data DockerClientOpts = DockerClientOpts {
319 apiVer :: ApiVersion
254 apiVer :: ApiVersion
320 , baseUrl :: URL
255 , baseUrl :: URL
321 }
256 }
322 deriving (Eq, Show)
257 deriving (Eq, Show)
323
258
324−-- | Default "DockerClientOpts" used for talking to the docker engine.
325defaultClientOpts :: DockerClientOpts
259defaultClientOpts :: DockerClientOpts
326defaultClientOpts = DockerClientOpts {
260defaultClientOpts = DockerClientOpts {
327 apiVer = "v1.24"
261 apiVer = "v1.24"
328 , baseUrl = "http://127.0.0.1:2375"
262 , baseUrl = "http://127.0.0.1:2375"
329 }
263 }
330
264
331−-- | List options used for filtering the list of container or images.
332data ListOpts = ListOpts { all :: Bool } deriving (Eq, Show)
265data ListOpts = ListOpts { all :: Bool } deriving (Eq, Show)
333
266
334−-- | Default "ListOpts". Doesn't list stopped containers.
335defaultListOpts :: ListOpts
267defaultListOpts :: ListOpts
336defaultListOpts = ListOpts { all=False }
268defaultListOpts = ListOpts { all=False }
337
269
338−-- | Data type used for represneting the version of the docker engine
339−-- remote API.
340data DockerVersion = DockerVersion {
270data DockerVersion = DockerVersion {
341 version :: Text
271 version :: Text
342 , apiVersion :: ApiVersion
272 , apiVersion :: ApiVersion
@@ -406,8 +336,6 @@ instance FromJSON ImageID where
406 return iid
336 return iid
407 parseJSON _ = fail "ImageID is not an object."
337 parseJSON _ = fail "ImageID is not an object."
408
338
409−-- | Data type used for representing the information of various ports that
410−-- a contianer may expose.
411data ContainerPortInfo = ContainerPortInfo {
339data ContainerPortInfo = ContainerPortInfo {
412 ipAddressInfo :: Maybe Text
340 ipAddressInfo :: Maybe Text
413 , privatePortInfo :: Port
341 , privatePortInfo :: Port
@@ -424,8 +352,6 @@ instance FromJSON ContainerPortInfo where
424 parseJSON _ = fail "ContainerPortInfo: Not a JSON object."
352 parseJSON _ = fail "ContainerPortInfo: Not a JSON object."
425
353
426-- For inspecting container details.
354-- For inspecting container details.
427−-- | Data type used for parsing the network information of each container
428−-- when listing them.
429data NetworkOptions = NetworkOptions {
355data NetworkOptions = NetworkOptions {
430-- ipamConfig :: Maybe Text -- Don't see in 1.24
356-- ipamConfig :: Maybe Text -- Don't see in 1.24
431-- , links :: Maybe Text -- Don't see in 1.24
357-- , links :: Maybe Text -- Don't see in 1.24
@@ -455,28 +381,29 @@ instance FromJSON NetworkOptions where
455 return $ NetworkOptions networkId endpointId gateway ip ipLen ip6Gateway globalIP6 globalIP6Len mac
381 return $ NetworkOptions networkId endpointId gateway ip ipLen ip6Gateway globalIP6 globalIP6Len mac
456 parseJSON _ = fail "NetworkOptions is not an object"
382 parseJSON _ = fail "NetworkOptions is not an object"
457
383
458−-- TODO: Not sure what this is used for anymore.
384+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
460 deriving (Eq, Show)
385 deriving (Eq, Show)
461
386
462−instance {-# OVERLAPPING #-} FromJSON [Network] where
387+instance FromJSON Networks where
463− parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
388+ parseJSON (JSON.Object o) = do
389+ Networks <$> HM.foldlWithKey' f (return M.empty) o
390+
464 where
391 where
465 f accM k' v' = do
392 f accM k' v' = do
466 acc <- accM
393 acc <- accM
467 k <- parseJSON $ JSON.String k'
394 k <- parseJSON $ JSON.String k'
468 v <- parseJSON v'
395 v <- parseJSON v'
469− return $ (Network k v):acc
396+ return $ M.insert k v acc
397+
470 parseJSON _ = fail "Networks is not an object"
398 parseJSON _ = fail "Networks is not an object"
471
399
472−-- | Data type reprsenting the various network settings a container can have.
473data NetworkSettings = NetworkSettings {
400data NetworkSettings = NetworkSettings {
474 networkSettingsBridge :: Text
401 networkSettingsBridge :: Text
475 , networkSettingsSandboxId :: Text
402 , networkSettingsSandboxId :: Text
476 , networkSettingsHairpinMode :: Bool
403 , networkSettingsHairpinMode :: Bool
477 , networkSettingsLinkLocalIPv6Address :: Text
404 , networkSettingsLinkLocalIPv6Address :: Text
478 , networkSettingsLinkLocalIPv6PrefixLen :: Int
405 , networkSettingsLinkLocalIPv6PrefixLen :: Int
479− , networkSettingsPorts :: [PortBinding]
406+ , networkSettingsPorts :: PortBindings
480 , networkSettingsSandboxKey :: Text
407 , networkSettingsSandboxKey :: Text
481 , networkSettingsSecondaryIPAddresses :: Maybe [Text] -- TODO: 1.24 spec is unclear
408 , networkSettingsSecondaryIPAddresses :: Maybe [Text] -- TODO: 1.24 spec is unclear
482 , networkSettingsSecondaryIPv6Addresses :: Maybe [Text] -- TODO: 1.24 spec is unclear
409 , networkSettingsSecondaryIPv6Addresses :: Maybe [Text] -- TODO: 1.24 spec is unclear
@@ -488,7 +415,7 @@ data NetworkSettings = NetworkSettings {
488 , networkSettingsIpPrefixLen :: Int
415 , networkSettingsIpPrefixLen :: Int
489 , networkSettingsIpv6Gateway :: Text
416 , networkSettingsIpv6Gateway :: Text
490 , networkSettingsMacAddress :: Text
417 , networkSettingsMacAddress :: Text
491− , networkSettingsNetworks :: [Network]
418+ , networkSettingsNetworks :: Networks
492 }
419 }
493 deriving (Eq, Show)
420 deriving (Eq, Show)
494
421
@@ -515,7 +442,6 @@ instance FromJSON NetworkSettings where
515 return $ NetworkSettings bridge sandbox hairpin localIP6 localIP6Len ports sandboxKey secondaryIP secondayIP6 endpointID gateway globalIP6 globalIP6Len ip ipLen ip6Gateway mac networks
442 return $ NetworkSettings bridge sandbox hairpin localIP6 localIP6Len ports sandboxKey secondaryIP secondayIP6 endpointID gateway globalIP6 globalIP6Len ip ipLen ip6Gateway mac networks
516 parseJSON _ = fail "NetworkSettings is not an object."
443 parseJSON _ = fail "NetworkSettings is not an object."
517
444
518−-- | Data type used for parsing a list of containers.
519data Container = Container
445data Container = Container
520 { containerId :: ContainerID
446 { containerId :: ContainerID
521 , containerNames :: [Text]
447 , containerNames :: [Text]
@@ -523,23 +449,21 @@ data Container = Container
523 , containerImageId :: ImageID
449 , containerImageId :: ImageID
524 , containerCommand :: Text
450 , containerCommand :: Text
525 , containerCreatedAt :: Int
451 , containerCreatedAt :: Int
526− , containerState :: State
527− , containerStatus :: Maybe Text
452+ , containerStatus :: Status
528 , containerPorts :: [ContainerPortInfo]
453 , containerPorts :: [ContainerPortInfo]
529− , containerLabels :: [Label]
454+ , containerLabels :: Labels
530− , containerNetworks :: [Network]
455+ , containerNetworks :: Networks
531 , containerMounts :: [Mount]
456 , containerMounts :: [Mount]
532 } deriving (Show, Eq)
457 } deriving (Show, Eq)
533
458
534instance FromJSON Container where
459instance FromJSON Container where
535− parseJSON o@(JSON.Object v) =
460+ parseJSON (JSON.Object v) =
536− Container <$> parseJSON o
461+ Container <$> (v .: "Id")
537 <*> (v .: "Names")
462 <*> (v .: "Names")
538 <*> (v .: "Image")
463 <*> (v .: "Image")
539− <*> (v .: "ImageID") -- Doesn't exist anymore
464+ <*> (v .: "ImageID")
540− <*> (v .: "Command") -- Doesn't exist anymore
465+ <*> (v .: "Command")
541 <*> (v .: "Created")
466 <*> (v .: "Created")
542− <*> (v .: "State")
543 <*> (v .: "Status")
467 <*> (v .: "Status")
544 <*> (v .: "Ports")
468 <*> (v .: "Ports")
545 <*> (v .: "Labels")
469 <*> (v .: "Labels")
@@ -549,124 +473,65 @@ instance FromJSON Container where
549 parseNetworks (JSON.Object v) =
473 parseNetworks (JSON.Object v) =
550 (v .: "Networks") >>= parseJSON
474 (v .: "Networks") >>= parseJSON
551 parseNetworks _ = fail "Container NetworkSettings: Not a JSON object."
475 parseNetworks _ = fail "Container NetworkSettings: Not a JSON object."
476+
552 parseJSON _ = fail "Container: Not a JSON object."
477 parseJSON _ = fail "Container: Not a JSON object."
553
478
554−-- | Represents the state of the container life cycle.
555−data State = Created | Restarting | Running | Paused | Exited | Dead
479+data Status = Created | Restarting | Running | Paused | Exited | Dead
556 deriving (Eq, Show, Generic)
480 deriving (Eq, Show, Generic)
557
481
558−instance FromJSON State where
482+instance FromJSON Status where
559− parseJSON (JSON.String "running") = return Running
483+ parseJSON (JSON.String "running") = return Running
560− parseJSON (JSON.String "created") = return Created -- Note: Guessing on the string values of these.
484+ parseJSON (JSON.String "created") = return Created -- Note: Guessing on the string values of these.
561 parseJSON (JSON.String "restarting") = return Restarting
485 parseJSON (JSON.String "restarting") = return Restarting
562− parseJSON (JSON.String "paused") = return Paused
486+ parseJSON (JSON.String "paused") = return Paused
563− parseJSON (JSON.String "exited") = return Exited
487+ parseJSON (JSON.String "exited") = return Exited
564− parseJSON (JSON.String "dead") = return Dead
488+ parseJSON (JSON.String "dead") = return Dead
565− parseJSON s = fail $ "Unknown Status: " ++ show s
489+ parseJSON _ = fail "Unknown Status"
566
490
567−-- | Alias for representing a RepoDigest. We could newtype this and add
568−-- some validation.
569type Digest = Text
491type Digest = Text
570
492
571−-- | Container and Image Labels.
572−data Label = Label Name Value deriving (Eq, Show)
493+newtype Labels = Labels (M.Map Name Value) deriving (Eq, Show)
573
494
495+instance FromJSON Labels where
496+ parseJSON val = Labels <$> parseJSON val
574
497
575−-- If there are multiple lables with the same Name in the list
576−-- then the last one wins.
577−instance {-# OVERLAPPING #-} ToJSON [Label] where
498+instance ToJSON Labels where
578− toJSON [] = emptyJsonObject
499+ toJSON (Labels kvs) = object [k .= v | (k,v) <- (M.toList kvs)]
579− toJSON (l:ls) = toJsonKeyVal (l:ls) key val
580− where key (Label k _) = T.unpack k
581− val (Label _ v) = v
582
500
583−instance {-# OVERLAPPING #-} FromJSON [Label] where
584− parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
585− where f accM k v = do
586− acc <- accM
587− value <- parseJSON v
588− return $ (Label k value):acc
589− parseJSON JSON.Null = return []
590− parseJSON _ = fail "Failed to parse Labels. Not an object."
591−
592−-- | Alias for Tags.
593type Tag = Text
501type Tag = Text
594
502
595−-- | Data type used for parsing information from a list of images.
596data Image = DockerImage {
503data Image = DockerImage {
597 imageId :: ImageID
504 imageId :: ImageID
598 , imageCreated :: Integer
505 , imageCreated :: Integer
599 , imageParentId :: Maybe ImageID
506 , imageParentId :: Maybe ImageID
600 , imageRepoTags :: [Tag]
507 , imageRepoTags :: [Tag]
601− , imageRepoDigests :: [Digest]
508+ , imageRepoDigests :: Maybe [Digest]
602 , imageSize :: Integer
509 , imageSize :: Integer
603 , imageVirtualSize :: Integer
510 , imageVirtualSize :: Integer
604− , imageLabels :: [Label]
511+ , imageLabels :: Maybe Labels
605 } deriving (Show, Eq, Generic)
512 } deriving (Show, Eq, Generic)
606
513
607−-- | Helper function used for dropping the "image" prefix when serializing
608−-- the Image data type to and from json.
609dropImagePrefix :: [a] -> [a]
514dropImagePrefix :: [a] -> [a]
610dropImagePrefix = drop 5
515dropImagePrefix = drop 5
611
516
612−
613instance FromJSON Image where
517instance FromJSON Image where
614− parseJSON (JSON.Object o) = do
518+ parseJSON = genericParseJSON defaultOptions {
615− imageId <- o .: "Id"
519+ fieldLabelModifier = dropImagePrefix}
616− imageCreated <- o .: "Created"
520+
617− imageParentId <- o .:? "ParentId"
618− imageRepoTags <- o .:? "RepoTags" .!= []
619− imageRepoDigests <- o .:? "RepoDigests" .!= []
620− imageSize <- o .: "Size"
621− imageVirtualSize <- o .: "VirtualSize"
622− imageLabels <- o .:? "Labels" .!= []
623− return $ DockerImage imageId imageCreated imageParentId imageRepoTags imageRepoDigests imageSize imageVirtualSize imageLabels
624− parseJSON _ = fail "Failed to parse DockerImage."
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− ]
649−
650−-- | Options used for creating a Container.
651data CreateOpts = CreateOpts {
521data CreateOpts = CreateOpts {
652− containerConfig :: ContainerConfig
522+ containerConfig :: ContainerConfig
653− , hostConfig :: HostConfig
523+ , hostConfig :: HostConfig
654− , networkingConfig :: NetworkingConfig
655 } deriving (Eq, Show)
524 } deriving (Eq, Show)
656
525
657instance ToJSON CreateOpts where
526instance ToJSON CreateOpts where
658− toJSON (CreateOpts cc hc nc) = do
527+ toJSON (CreateOpts cc hc) = do
659 let ccJSON = toJSON cc
528 let ccJSON = toJSON cc
660 let hcJSON = toJSON hc
529 let hcJSON = toJSON hc
661 case ccJSON of
530 case ccJSON of
662 JSON.Object (o :: HM.HashMap T.Text JSON.Value) -> do
531 JSON.Object (o :: HM.HashMap T.Text JSON.Value) -> do
663− let o1 = HM.insert "HostConfig" hcJSON o
532+ JSON.Object $ HM.insert "HostConfig" hcJSON o
664− let o2 = HM.insert "NetworkingConfig" (toJSON nc) o1
665− JSON.Object o2
666 _ -> error "ContainerConfig is not an object." -- This should never happen.
533 _ -> error "ContainerConfig is not an object." -- This should never happen.
667
534
668−-- | Container configuration used for creating a container with sensible
669−-- defaults.
670defaultContainerConfig :: Text -> ContainerConfig
535defaultContainerConfig :: Text -> ContainerConfig
671defaultContainerConfig imageName = ContainerConfig {
536defaultContainerConfig imageName = ContainerConfig {
672 hostname=Nothing
537 hostname=Nothing
@@ -676,29 +541,28 @@ defaultContainerConfig imageName = ContainerConfig {
676 , attachStdout=False
541 , attachStdout=False
677 , image=imageName
542 , image=imageName
678 , attachStderr=False
543 , attachStderr=False
679− , exposedPorts=[]
544+ , exposedPorts=Nothing -- ExposedPorts M.empty
680 , tty=False
545 , tty=False
681 , openStdin=False
546 , openStdin=False
682 , stdinOnce=False
547 , stdinOnce=False
683 , env=[]
548 , env=[]
684 , cmd=[]
549 , cmd=[]
685− , volumes=[]
550+ , volumes=Nothing
686 , workingDir=Nothing
551 , workingDir=Nothing
687− , entrypoint=Entrypoint []
552+ , entrypoint=Nothing
688 , networkDisabled=Nothing
553 , networkDisabled=Nothing
689 , macAddress=Nothing
554 , macAddress=Nothing
690− , labels=[]
555+ , labels=Nothing
691 , stopSignal=SIGTERM
556 , stopSignal=SIGTERM
692 }
557 }
693
558
694−-- | Default host confiratuon used for creating a container.
695defaultHostConfig :: HostConfig
559defaultHostConfig :: HostConfig
696defaultHostConfig = HostConfig {
560defaultHostConfig = HostConfig {
697 binds=[]
561 binds=[]
698 , containerIDFile=Nothing
562 , containerIDFile=Nothing
699− , logConfig=LogDriverConfig JsonFile []
563+ , logConfig=LogDriverConfig JsonFile Nothing
700− , networkMode=NetworkBridge
564+ , networkMode=Bridge
701− , portBindings=[]
565+ , portBindings=PortBindings []
702 , restartPolicy=RestartOff
566 , restartPolicy=RestartOff
703 , volumeDriver=Nothing
567 , volumeDriver=Nothing
704 , volumesFrom=[]
568 , volumesFrom=[]
@@ -719,7 +583,6 @@ defaultHostConfig = HostConfig {
719 , resources=defaultContainerResources
583 , resources=defaultContainerResources
720 }
584 }
721
585
722−-- Default container resource contstraints (None).
723defaultContainerResources :: ContainerResources
586defaultContainerResources :: ContainerResources
724defaultContainerResources = ContainerResources {
587defaultContainerResources = ContainerResources {
725 cpuShares=Nothing
588 cpuShares=Nothing
@@ -737,80 +600,34 @@ defaultContainerResources = ContainerResources {
737 , memory=Nothing
600 , memory=Nothing
738 , memoryReservation=Nothing
601 , memoryReservation=Nothing
739 , memorySwap=Nothing
602 , memorySwap=Nothing
740− , oomKillDisable=Just False
603+ , oomKillDisable=False
741 , ulimits=[]
604 , ulimits=[]
742 }
605 }
743
606
744−-- | Default create options when creating a container. You only need to
607+
745−-- specify an image name and the rest is all sensible defaults.
746defaultCreateOpts :: T.Text -> CreateOpts
608defaultCreateOpts :: T.Text -> CreateOpts
747−defaultCreateOpts imageName = CreateOpts
748− { containerConfig = defaultContainerConfig imageName
609+defaultCreateOpts imageName = CreateOpts { containerConfig = defaultContainerConfig imageName, hostConfig = defaultHostConfig }
749− , hostConfig = defaultHostConfig
750− , networkingConfig = NetworkingConfig HM.empty
751− }
752
610
753−-- | Override the key sequence for detaching a container.
611+-- detachKeys – Override the key sequence for detaching a container.
754-- Format is a single character [a-Z] or ctrl-<value> where <value> is one of: a-z, @, ^, [, , or _.
612-- Format is a single character [a-Z] or ctrl-<value> where <value> is one of: a-z, @, ^, [, , or _.
755data DetachKeys = WithCtrl Char | WithoutCtrl Char | DefaultDetachKey deriving (Eq, Show)
613data DetachKeys = WithCtrl Char | WithoutCtrl Char | DefaultDetachKey deriving (Eq, Show)
756
614
757−-- | Options for starting a container.
758data StartOpts = StartOpts { detachKeys :: DetachKeys } deriving (Eq, Show)
615data StartOpts = StartOpts { detachKeys :: DetachKeys } deriving (Eq, Show)
759
616
760−-- | Default options for staring a container.
761defaultStartOpts :: StartOpts
617defaultStartOpts :: StartOpts
762defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }
618defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }
763
619
764−-- | Options for deleting a container.
620+data DeleteOpts = DeleteOpts {
765−data ContainerDeleteOpts = ContainerDeleteOpts {
766 deleteVolumes :: Bool -- ^ Automatically cleanup volumes that the container created as well.
621 deleteVolumes :: Bool -- ^ Automatically cleanup volumes that the container created as well.
767 , force :: Bool -- ^ If the container is still running force deletion anyway.
622 , force :: Bool -- ^ If the container is still running force deletion anyway.
768 } deriving (Eq, Show)
623 } deriving (Eq, Show)
769
624
770−-- TODO: Add support for container build constraints
625+defaultDeleteOpts :: DeleteOpts
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−
792−-- | Default options for deleting a container. Most of the time we DON'T
793−-- want to delete the container's volumes or force delete it if it's
794−-- running.
795−defaultContainerDeleteOpts :: ContainerDeleteOpts
796−defaultContainerDeleteOpts = ContainerDeleteOpts { deleteVolumes = False, force = False }
626+defaultDeleteOpts = DeleteOpts { 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
804−
805−-- | Timestamp alias.
806−type Timestamp = Integer
807
627
808−-- | Used for requesting N number of lines when tailing a containers log
628+type Timestamp = Integer
809−-- output.
810data TailLogOpt = Tail Integer | All deriving (Eq, Show)
629data TailLogOpt = Tail Integer | All deriving (Eq, Show)
811
630
812−
813−-- | Log options used when requesting the log output from a container.
814data LogOpts = LogOpts {
631data LogOpts = LogOpts {
815 stdout :: Bool
632 stdout :: Bool
816 , stderr :: Bool
633 , stderr :: Bool
@@ -819,7 +636,6 @@ data LogOpts = LogOpts {
819 , tail :: TailLogOpt
636 , tail :: TailLogOpt
820 } deriving (Eq, Show)
637 } deriving (Eq, Show)
821
638
822−-- | Sensible default for log options.
823defaultLogOpts :: LogOpts
639defaultLogOpts :: LogOpts
824defaultLogOpts = LogOpts { stdout = True
640defaultLogOpts = LogOpts { stdout = True
825 , stderr = True
641 , stderr = True
@@ -828,87 +644,37 @@ defaultLogOpts = LogOpts { stdout = True
828 , tail = All
644 , tail = All
829 }
645 }
830
646
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−
861−-- TOOD: Add support for SELinux Volume labels (eg. "ro,z" or "ro/Z")
862−-- | Set permissions on volumes that you mount in the container.
863−data VolumePermission = ReadWrite | ReadOnly deriving (Eq, Show, Generic)
647+data VolumePermission = Rw | Ro deriving (Eq, Show, Generic)
864−
865−instance ToJSON VolumePermission where
866− toJSON ReadWrite = "rw"
867− toJSON ReadOnly = "ro"
868−
869−instance FromJSON VolumePermission where
870− parseJSON "rw" = return ReadWrite
871− parseJSON "ro" = return ReadOnly
872− parseJSON "RW" = return ReadWrite
873− parseJSON "RO" = return ReadOnly
874− parseJSON _ = fail "Failed to parse VolumePermission"
875−
876−-- | Used for marking a directory in the container as "exposed" hence
877−-- taking it outside of the COW filesystem and making it mountable
878−-- in other containers using "VolumesFrom". The volume usually get's
879−-- created somewhere in @/var/lib/docker/volumes@ (depending on the volume
880−-- driver used).
881−-- The CLI example is:
882−--
883−-- @
884−-- docker run --name app -v \/opt\/data -it myapp:latest
885−-- docker run --name app2 --volumes-from app \/bin\/bash -c "ls -l \/opt\/data"
886−-- @
887−newtype Volume = Volume FilePath deriving (Eq, Show)
888−
889−instance {-# OVERLAPPING #-} ToJSON [Volume] where
890− toJSON [] = emptyJsonObject
891− toJSON (v:vs) = toJsonKey (v:vs) getKey
892− where getKey (Volume v) = v
893−
894−instance {-# OVERLAPPING #-} FromJSON [Volume] where
895− parseJSON (JSON.Object o) = return $ map (Volume . T.unpack) $ HM.keys o
896− parseJSON (JSON.Null) = return []
897− parseJSON _ = fail "Volume is not an object"
898−
899−
900−data Bind = Bind { hostSrc :: Text
901− , containerDest :: Text
902− , volumePermission :: Maybe VolumePermission
903− } deriving (Eq, Show)
904
648
649+-- instance ToJSON VolumePermission where
650+-- toJSON = error "TODO"
651+-- instance FromJSON VolumePermission where
652+-- parseJSON = error "TODO"
653+
654+-- Note: Note really sure what this should be (1.24).
655+-- This is not the same as [Volume] in HostConfig.
656+newtype Volumes = Volumes [Text] -- [Volume]
657+ deriving (Eq, Show)
658+
905−instance FromJSON Bind where
659+instance FromJSON Volumes where
660+ parseJSON (JSON.Object o) = return $ Volumes $ HM.keys o
661+ parseJSON _ = fail "Volumes is not an object"
662+
663+instance ToJSON Volumes where
664+ toJSON (Volumes vs) = toJSON vs
665+
666+data Volume = Volume { hostSrc :: Text
667+ , containerDest :: Text
668+ , volumePermission :: Maybe VolumePermission
669+ } deriving (Eq, Show)
670+
671+instance FromJSON Volume where
906 parseJSON (JSON.String t) = case T.split (== ':') t of
672 parseJSON (JSON.String t) = case T.split (== ':') t of
907− [src, dest] -> return $ Bind src dest Nothing
673+ [src, dest] -> return $ Volume src dest Nothing
908− [src, dest, "rw"] -> return $ Bind src dest $ Just ReadWrite
674+ [src, dest, "rw"] -> return $ Volume src dest $ Just Rw
909− [src, dest, "ro"] -> return $ Bind src dest $ Just ReadOnly
675+ [src, dest, "ro"] -> return $ Volume src dest $ Just Ro
910− _ -> fail "Could not parse Bind"
676+ _ -> fail "Could not parse Volume"
911− parseJSON _ = fail "Bind is not a string"
677+ parseJSON _ = fail "Volume is not a string"
912
678
913data Device = Device {
679data Device = Device {
914 pathOnHost :: FilePath
680 pathOnHost :: FilePath
@@ -930,19 +696,19 @@ data VolumeFrom = VolumeFrom ContainerName (Maybe VolumePermission) deriving (Eq
930
696
931instance FromJSON VolumeFrom where
697instance FromJSON VolumeFrom where
932 parseJSON (JSON.String t) = case T.split (== ':') t of
698 parseJSON (JSON.String t) = case T.split (== ':') t of
933− [vol] -> return $ VolumeFrom vol Nothing
699+ [vol] -> return $ VolumeFrom vol Nothing
934− [vol, "rw"] -> return $ VolumeFrom vol $ Just ReadWrite
700+ [vol, "rw"] -> return $ VolumeFrom vol $ Just Rw
935− [vol, "ro"] -> return $ VolumeFrom vol $ Just ReadOnly
701+ [vol, "ro"] -> return $ VolumeFrom vol $ Just Ro
936− _ -> fail "Could not parse VolumeFrom"
702+ _ -> fail "Could not parse VolumeFrom"
937 parseJSON _ = fail "VolumeFrom is not a string"
703 parseJSON _ = fail "VolumeFrom is not a string"
938
704
939instance ToJSON VolumeFrom where
705instance ToJSON VolumeFrom where
940 toJSON (VolumeFrom n p) = case p of
706 toJSON (VolumeFrom n p) = case p of
941− Nothing -> toJSON $ n <> ":" <> "rw"
707+ Nothing -> toJSON $ n <> ":" <> "rw"
942 Just per -> toJSON $ n <> ":" <> (T.pack $ show per)
708 Just per -> toJSON $ n <> ":" <> (T.pack $ show per)
943
709
944−instance ToJSON Bind where
710+instance ToJSON Volume where
945− toJSON (Bind src dest mode) = toJSON $ case mode of
711+ toJSON (Volume src dest mode) = toJSON $ case mode of
946 Nothing -> T.concat[src, ":", dest]
712 Nothing -> T.concat[src, ":", dest]
947 Just m -> T.concat[src, ":", dest, ":", (T.pack $ show m)]
713 Just m -> T.concat[src, ":", dest, ":", (T.pack $ show m)]
948
714
@@ -950,63 +716,63 @@ data Link = Link Text (Maybe Text) deriving (Eq, Show)
950
716
951instance FromJSON Link where
717instance FromJSON Link where
952 parseJSON (JSON.String t) = case T.split (== ':') t of
718 parseJSON (JSON.String t) = case T.split (== ':') t of
953− [f] -> return $ Link f Nothing
719+ [f] -> return $ Link f Nothing
954 [f,s] -> return $ Link f $ Just s
720 [f,s] -> return $ Link f $ Just s
955− _ -> fail "Could not parse Link"
721+ _ -> fail "Could not parse Link"
956 parseJSON _ = fail "Link is not a string"
722 parseJSON _ = fail "Link is not a string"
957
723
958instance ToJSON Link where
724instance ToJSON Link where
959 toJSON (Link n1 n2) = toJSON $ case n2 of
725 toJSON (Link n1 n2) = toJSON $ case n2 of
960 Nothing -> T.concat[n1, ":", n1] -- use same name in container
726 Nothing -> T.concat[n1, ":", n1] -- use same name in container
961− Just n -> T.concat[n1, ":", n] -- used specified name in container
727+ Just n -> T.concat[n1, ":", n] -- used specified name in container
962
728
963-- { "Type": "<driver_name>", "Config": {"key1": "val1"} }
729-- { "Type": "<driver_name>", "Config": {"key1": "val1"} }
964data LogDriverType = JsonFile | Syslog | Journald | Gelf | Fluentd | AwsLogs | Splunk | Etwlogs | LoggingDisabled deriving (Eq, Show)
730data LogDriverType = JsonFile | Syslog | Journald | Gelf | Fluentd | AwsLogs | Splunk | Etwlogs | LoggingDisabled deriving (Eq, Show)
965
731
966instance FromJSON LogDriverType where
732instance FromJSON LogDriverType where
967 parseJSON (JSON.String "json-file") = return JsonFile
733 parseJSON (JSON.String "json-file") = return JsonFile
968− parseJSON (JSON.String "syslog") = return Syslog
734+ parseJSON (JSON.String "syslog") = return Syslog
969− parseJSON (JSON.String "journald") = return Journald
735+ parseJSON (JSON.String "journald") = return Journald
970− parseJSON (JSON.String "gelf") = return Gelf
736+ parseJSON (JSON.String "gelf") = return Gelf
971− parseJSON (JSON.String "fluentd") = return Fluentd
737+ parseJSON (JSON.String "fluentd") = return Fluentd
972− parseJSON (JSON.String "awslogs") = return AwsLogs
738+ parseJSON (JSON.String "awslogs") = return AwsLogs
973− parseJSON (JSON.String "splunk") = return Splunk
739+ parseJSON (JSON.String "splunk") = return Splunk
974− parseJSON (JSON.String "etwlogs") = return Etwlogs
740+ parseJSON (JSON.String "etwlogs") = return Etwlogs
975− parseJSON (JSON.String "none") = return LoggingDisabled
741+ parseJSON (JSON.String "none") = return LoggingDisabled
976− parseJSON _ = fail "Unknown LogDriverType"
742+ parseJSON _ = fail "Unknown LogDriverType"
977
743
978instance ToJSON LogDriverType where
744instance ToJSON LogDriverType where
979− toJSON JsonFile = JSON.String "json-file"
745+ toJSON JsonFile = JSON.String "json-file"
980− toJSON Syslog = JSON.String "syslog"
746+ toJSON Syslog = JSON.String "syslog"
981− toJSON Journald = JSON.String "journald"
747+ toJSON Journald = JSON.String "journald"
982− toJSON Gelf = JSON.String "gelf"
748+ toJSON Gelf = JSON.String "gelf"
983− toJSON Fluentd = JSON.String "fluentd"
749+ toJSON Fluentd = JSON.String "fluentd"
984− toJSON AwsLogs = JSON.String "awslogs"
750+ toJSON AwsLogs = JSON.String "awslogs"
985− toJSON Splunk = JSON.String "splunk"
751+ toJSON Splunk = JSON.String "splunk"
986− toJSON Etwlogs = JSON.String "etwlogs"
752+ toJSON Etwlogs = JSON.String "etwlogs"
987 toJSON LoggingDisabled = JSON.String "none"
753 toJSON LoggingDisabled = JSON.String "none"
988
754
989−data LogDriverOption = LogDriverOption Name Value deriving (Eq, Show)
755+newtype LogDriverOptions = LogDriverOptions (M.Map Text Text) deriving (Eq, Show)
990
756
991−instance {-# OVERLAPPING #-} ToJSON [LogDriverOption] where
757+instance FromJSON LogDriverOptions where
992− toJSON [] = emptyJsonObject
758+ parseJSON (JSON.Object o) = do
993− toJSON (o:os) = toJsonKeyVal (o:os) key val
759+ LogDriverOptions <$> HM.foldlWithKey' f (return M.empty) o
994− where key (LogDriverOption n _) = T.unpack n
995− val (LogDriverOption _ v) = v
996
760
997−instance {-# OVERLAPPING #-} FromJSON [LogDriverOption] where
761+ where
998− parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
999− where f accM k v = do
762+ f accM k (JSON.String v) = do
1000 acc <- accM
763 acc <- accM
1001− value <- parseJSON v
764+ return $ M.insert k v acc
1002− return $ (LogDriverOption k value):acc
765+ f _ _ _ = fail "Value of LogDriverOptions is not a string"
766+
1003− parseJSON JSON.Null = return []
767+ parseJSON JSON.Null = return $ LogDriverOptions M.empty
1004− parseJSON _ = fail "Failed to parse LogDriverOptions"
768+ parseJSON _ = fail "LogDriverOptions is not an object"
1005
769
770+instance ToJSON LogDriverOptions where
771+ toJSON (LogDriverOptions mp) = toJSON mp
772+
1006−data LogDriverConfig = LogDriverConfig LogDriverType [LogDriverOption] deriving (Eq, Show)
773+data LogDriverConfig = LogDriverConfig LogDriverType (Maybe LogDriverOptions) deriving (Eq, Show)
1007
774
1008instance ToJSON LogDriverConfig where
775instance ToJSON LogDriverConfig where
1009− toJSON (LogDriverConfig driverType []) = object ["Type" .= driverType]
1010 toJSON (LogDriverConfig driverType driverOptions) = object ["Type" .= driverType, "Config" .= driverOptions]
776 toJSON (LogDriverConfig driverType driverOptions) = object ["Type" .= driverType, "Config" .= driverOptions]
1011
777
1012instance FromJSON LogDriverConfig where
778instance FromJSON LogDriverConfig where
@@ -1017,41 +783,19 @@ instance FromJSON LogDriverConfig where
1017 parseJSON _ = fail "LogDriverConfig is not an object"
783 parseJSON _ = fail "LogDriverConfig is not an object"
1018
784
1019-- TODO: Add container:<name|id> mode
785-- TODO: Add container:<name|id> mode
1020−data NetworkMode = NetworkBridge | NetworkHost | NetworkDisabled | NetworkNamed Text
786+data NetworkMode = Bridge | Host | NetworkDisabled
1021 deriving (Eq, Show, Ord)
787 deriving (Eq, Show, Ord)
1022
788
1023instance FromJSON NetworkMode where
789instance FromJSON NetworkMode where
1024− parseJSON (JSON.String "bridge") = return NetworkBridge
790+ parseJSON (JSON.String "bridge") = return Bridge
1025− parseJSON (JSON.String "host") = return NetworkHost -- Note: Guessing on these.
791+ parseJSON (JSON.String "host") = return Host -- Note: Guessing on these.
1026− parseJSON (JSON.String "none") = return NetworkDisabled
792+ parseJSON (JSON.String "none") = return NetworkDisabled
1027− parseJSON (JSON.String n) = return $ NetworkNamed n
1028− parseJSON _ = fail "Unknown NetworkMode"
793+ parseJSON _ = fail "Unknown NetworkMode"
1029
794
1030instance ToJSON NetworkMode where
795instance ToJSON NetworkMode where
1031− toJSON NetworkBridge = JSON.String "bridge"
796+ toJSON Bridge = JSON.String "bridge"
1032− toJSON NetworkHost = JSON.String "host"
797+ toJSON Host = JSON.String "host"
1033 toJSON NetworkDisabled = JSON.String "none"
798 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]
1055
799
1056data PortType = TCP | UDP deriving (Eq, Generic, Read, Ord)
800data PortType = TCP | UDP deriving (Eq, Generic, Read, Ord)
1057
801
@@ -1067,7 +811,7 @@ instance FromJSON PortType where
1067 parseJSON val = case val of
811 parseJSON val = case val of
1068 "tcp" -> return TCP
812 "tcp" -> return TCP
1069 "udp" -> return UDP
813 "udp" -> return UDP
1070− _ -> fail "PortType: Invalid port type."
814+ _ -> fail "PortType: Invalid port type."
1071
815
1072-- newtype NetworkInterface = NetworkInterface Text deriving (Eq, Show)
816-- newtype NetworkInterface = NetworkInterface Text deriving (Eq, Show)
1073--
817--
@@ -1083,7 +827,15 @@ instance FromJSON PortType where
1083-- the outside world. We either map a port onto all interfaces (default) or onto a specific
827-- the outside world. We either map a port onto all interfaces (default) or onto a specific
1084-- interface like `127.0.0.1`.
828-- interface like `127.0.0.1`.
1085-- __NOTE__: We should disallow duplicate port bindings as the ToJSON
829-- __NOTE__: We should disallow duplicate port bindings as the ToJSON
1086−-- instance will only send the last one.
830+-- instnace will only send the last one.
831+newtype PortBindings = PortBindings [PortBinding]
832+ deriving (Eq, Show)
833+
834+
835+instance Monoid PortBindings where
836+ mempty = PortBindings []
837+ mappend (PortBindings p1) (PortBindings p2) = PortBindings (p1 ++ p2)
838+
1087-- { <port>/<protocol>: [{ "HostPort": "<port>" }] }
839-- { <port>/<protocol>: [{ "HostPort": "<port>" }] }
1088data PortBinding = PortBinding {
840data PortBinding = PortBinding {
1089 containerPort :: Port
841 containerPort :: Port
@@ -1094,62 +846,24 @@ data PortBinding = PortBinding {
1094portAndType2Text :: Port -> PortType -> Text
846portAndType2Text :: Port -> PortType -> Text
1095portAndType2Text p t = (T.pack $ show p) <> "/" <> (T.pack $ show t)
847portAndType2Text p t = (T.pack $ show p) <> "/" <> (T.pack $ show t)
1096
848
1097−
1098−-- | A helper function to more easily add a bind mount to existing
1099−-- "CreateOpts" records.
1100−addBind :: Bind -> CreateOpts -> CreateOpts
1101−addBind b c = c{hostConfig=hc{binds=obs <> [b]}}
1102− where hc = hostConfig c
1103− obs = binds $ hostConfig c
1104−
1105−-- | Helper function for adding a Command to and existing
1106−-- CreateOpts record.
1107−setCmd :: Text -> CreateOpts -> CreateOpts
1108−setCmd ccmd c = c{containerConfig=cc{cmd=[ccmd]}}
1109− where cc = containerConfig c
1110−
1111−-- | Helper function for adding a "Link" to and existing
1112−-- CreateOpts record.
1113−addLink :: Link -> CreateOpts -> CreateOpts
1114−addLink l c = c{hostConfig=hc{links=ols <> [l]}}
1115− where hc = hostConfig c
1116− ols = links $ hostConfig c
1117−
1118−-- | Helper function for adding a "Volume" to and existing
1119−-- CreateOpts record.
1120−addVolume :: Volume -> CreateOpts -> CreateOpts
1121−addVolume v c = c{containerConfig=cc{volumes=oldvs <> [v]}}
1122− where cc = containerConfig c
1123− oldvs = volumes cc
1124−
1125−-- | Helper function for adding a "VolumeFrom" to and existing
1126−-- CreateOpts record.
1127−addVolumeFrom :: VolumeFrom -> CreateOpts -> CreateOpts
1128−addVolumeFrom vf c = c{hostConfig=hc{volumesFrom=oldvfs <> [vf]}}
1129− where hc = hostConfig c
1130− oldvfs = volumesFrom hc
1131−
1132-- | A convenience function that adds PortBindings to and exiting
849-- | A convenience function that adds PortBindings to and exiting
1133-- "CreateOpts" record. Useful with 'defaultCreateOpts'
850-- "CreateOpts" record. Useful with 'defaultCreateOpts'
1134-- Example:
851-- Example:
1135--
852--
1136-- >>> let pb = PortBinding 80 TCP [HostPort "0.0.0.0" 8000]
853-- >>> let pb = PortBinding 80 TCP [HostPort "0.0.0.0" 8000]
1137−-- >>> addPortBinding pb $ defaultCreateOpts "nginx:latest"
854+-- >>> addPortBinding (defaultCreateOpts "nginx:latest") pb
1138−addPortBinding :: PortBinding -> CreateOpts -> CreateOpts
855+addPortBinding :: CreateOpts -> PortBinding -> CreateOpts
1139−addPortBinding pb c = c{hostConfig=hc{portBindings=pbs <> [pb]}}
856+addPortBinding c pb = c{hostConfig=hc{portBindings=pbs <> PortBindings [pb]}}
1140 where hc = hostConfig c
857 where hc = hostConfig c
1141 pbs = portBindings $ hostConfig c
858 pbs = portBindings $ hostConfig c
1142
859
1143−-- | Helper function for adding a "ExposedPort" to and existing
860+instance ToJSON PortBinding where
1144−-- CreateOpts record.
861+ toJSON (PortBinding {..}) = object [portAndType2Text containerPort portType .= hostPorts]
1145−addExposedPort :: ExposedPort -> CreateOpts -> CreateOpts
1146−addExposedPort ep c = c{containerConfig=cc{exposedPorts=oldeps <> [ep]}}
1147− where cc = containerConfig c
1148− oldeps = exposedPorts cc
1149
862
863+instance FromJSON PortBindings where
864+ parseJSON (JSON.Object o) = do
865+ PortBindings <$> HM.foldlWithKey' f (return []) o
1150
866
1151−instance {-# OVERLAPPING #-} FromJSON [PortBinding] where
1152− parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
1153 where
867 where
1154 f accM k v = case T.split (== '/') k of
868 f accM k v = case T.split (== '/') k of
1155 [port', portType'] -> do
869 [port', portType'] -> do
@@ -1158,15 +872,16 @@ instance {-# OVERLAPPING #-} FromJSON [PortBinding] where
1158 acc <- accM
872 acc <- accM
1159 hps <- parseJSON v
873 hps <- parseJSON v
1160 return $ (PortBinding port portType hps):acc
874 return $ (PortBinding port portType hps):acc
875+ _ ->
1161− _ -> fail "Could not parse PortBindings"
876+ fail "Could not parse PortBindings"
1162− parseJSON (JSON.Null) = return []
1163 parseJSON _ = fail "PortBindings is not an object"
877 parseJSON _ = fail "PortBindings is not an object"
1164
878
1165−instance {-# OVERLAPPING #-} ToJSON [PortBinding] where
879+instance ToJSON PortBindings where
1166− toJSON [] = emptyJsonObject
880+ toJSON (PortBindings []) = JSON.Object HM.empty
1167− toJSON (p:ps) = toJsonKeyVal (p:ps) key val
881+ toJSON (PortBindings (p:ps)) = JSON.Object $ foldl f HM.empty (p:ps)
1168− where key p = T.unpack $ portAndType2Text (containerPort p) (portType p)
882+ where mKey p = portAndType2Text (containerPort p) (portType p)
1169− val p = hostPorts p
883+ mVal p = toJSON $ hostPorts p
884+ f acc p = HM.insert (mKey p) (mVal p) acc
1170
885
1171data HostPort = HostPort {
886data HostPort = HostPort {
1172 hostIp :: Text
887 hostIp :: Text
@@ -1184,6 +899,24 @@ instance FromJSON HostPort where
1184 return $ HostPort i p
899 return $ HostPort i p
1185 parseJSON _ = fail "HostPort is not an object."
900 parseJSON _ = fail "HostPort is not an object."
1186
901
902+-- newtype HostPorts = HostPorts [HostPort]
903+-- deriving (Eq, Show)
904+--
905+-- instance ToJSON HostPorts where
906+-- toJSON (HostPorts hps) = toJSON hps
907+--
908+-- instance FromJSON HostPorts where
909+-- parseJSON (JSON.Object o) = do
910+-- HostPorts <$> HM.foldlWithKey' f (return []) o
911+--
912+-- where
913+-- f accM k v = do
914+-- acc <- accM
915+-- p' <- parseJSON v
916+-- p <- parseIntegerText p'
917+-- return $ (HostPort (NetworkInterface k) p):acc
918+-- parseJSON _ = fail $ "HostPorts is not an object"
919+
1187-- { "Name": "on-failure" , "MaximumRetryCount": 2}
920-- { "Name": "on-failure" , "MaximumRetryCount": 2}
1188type RetryCount = Integer
921type RetryCount = Integer
1189data RestartPolicy = RestartAlways | RestartUnlessStopped | RestartOnFailure RetryCount | RestartOff deriving (Eq, Show)
922data RestartPolicy = RestartAlways | RestartUnlessStopped | RestartOnFailure RetryCount | RestartOff deriving (Eq, Show)
@@ -1197,7 +930,7 @@ instance FromJSON RestartPolicy where
1197 "on-failure" -> do
930 "on-failure" -> do
1198 retry <- o .: "MaximumRetryCount"
931 retry <- o .: "MaximumRetryCount"
1199 return $ RestartOnFailure retry
932 return $ RestartOnFailure retry
1200− "no" -> return RestartOff
933+ "off" -> return RestartOff
1201 _ -> fail "Could not parse RestartPolicy"
934 _ -> fail "Could not parse RestartPolicy"
1202 parseJSON _ = fail "RestartPolicy is not an object"
935 parseJSON _ = fail "RestartPolicy is not an object"
1203
936
@@ -1205,7 +938,7 @@ instance ToJSON RestartPolicy where
1205 toJSON RestartAlways = object ["Name" .= JSON.String "always"]
938 toJSON RestartAlways = object ["Name" .= JSON.String "always"]
1206 toJSON RestartUnlessStopped = object ["Name" .= JSON.String "unless-stopped"]
939 toJSON RestartUnlessStopped = object ["Name" .= JSON.String "unless-stopped"]
1207 toJSON (RestartOnFailure c) = object ["Name" .= JSON.String "on-failure", "MaximumRetryCount" .= c]
940 toJSON (RestartOnFailure c) = object ["Name" .= JSON.String "on-failure", "MaximumRetryCount" .= c]
1208− toJSON RestartOff = object ["Name" .= JSON.String "no"]
941+ toJSON RestartOff = object ["Name" .= JSON.String "off"]
1209
942
1210data Isolation = Default | Process | Hyperv deriving (Eq, Show)
943data Isolation = Default | Process | Hyperv deriving (Eq, Show)
1211
944
@@ -1215,11 +948,11 @@ newtype UTSMode = UTSMode Text deriving (Eq, Show)
1215-- TODO: Add UTSMode : UTS namespace to use for the container
948-- TODO: Add UTSMode : UTS namespace to use for the container
1216-- TODO: Sysctls map[string]string `json:",omitempty"` // List of Namespaced sysctls used for the container
949-- TODO: Sysctls map[string]string `json:",omitempty"` // List of Namespaced sysctls used for the container
1217data HostConfig = HostConfig
950data HostConfig = HostConfig
1218− { binds :: [Bind]
951+ { binds :: [Volume]
1219 , containerIDFile :: Maybe FilePath -- 1.24: Only in responses, not create
952 , containerIDFile :: Maybe FilePath -- 1.24: Only in responses, not create
1220 , logConfig :: LogDriverConfig
953 , logConfig :: LogDriverConfig
1221 , networkMode :: NetworkMode
954 , networkMode :: NetworkMode
1222− , portBindings :: [PortBinding]
955+ , portBindings :: PortBindings
1223 , restartPolicy :: RestartPolicy
956 , restartPolicy :: RestartPolicy
1224 , volumeDriver :: Maybe Text
957 , volumeDriver :: Maybe Text
1225 , volumesFrom :: [VolumeFrom]
958 , volumesFrom :: [VolumeFrom]
@@ -1378,22 +1111,6 @@ instance ToJSON DeviceRate where
1378 , "Rate" .= r
1111 , "Rate" .= r
1379 ]
1112 ]
1380
1113
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−
1397data ContainerResources = ContainerResources {
1114data ContainerResources = ContainerResources {
1398 cpuShares :: Maybe Integer
1115 cpuShares :: Maybe Integer
1399 -- , cgroupParent :: Text -- 1.24: Missing from inspecting container details... Going to omit for now.
1116 -- , cgroupParent :: Text -- 1.24: Missing from inspecting container details... Going to omit for now.
@@ -1409,12 +1126,12 @@ data ContainerResources = ContainerResources {
1409 , cpusetMems :: Maybe Text
1126 , cpusetMems :: Maybe Text
1410 , devices :: [Device]
1127 , devices :: [Device]
1411 -- , diskQuota :: Integer -- Don't see this ins 1.24.
1128 -- , diskQuota :: Integer -- Don't see this ins 1.24.
1412− , kernelMemory :: Maybe MemoryConstraint
1129+ , kernelMemory :: Maybe Integer
1413− , memory :: Maybe MemoryConstraint
1130+ , memory :: Maybe Integer
1414− , memoryReservation :: Maybe MemoryConstraint
1131+ , memoryReservation :: Maybe Integer
1415− , memorySwap :: Maybe MemoryConstraint
1132+ , memorySwap :: Maybe Integer
1416 -- , memorySwappiness :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.
1133 -- , memorySwappiness :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.
1417− , oomKillDisable :: Maybe Bool
1134+ , oomKillDisable :: Bool
1418 -- , pidsLimit :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.
1135 -- , pidsLimit :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.
1419 , ulimits :: [Ulimit]
1136 , ulimits :: [Ulimit]
1420 -- TODO: Missing from 1.24
1137 -- TODO: Missing from 1.24
@@ -1452,59 +1169,41 @@ instance FromJSON EnvVar where
1452 parseJSON _ = fail "EnvVar is not a string"
1169 parseJSON _ = fail "EnvVar is not a string"
1453
1170
1454instance ToJSON EnvVar where
1171instance ToJSON EnvVar where
1455− toJSON (EnvVar n v) = JSON.String $ n <> T.pack "=" <> v
1172+ toJSON (EnvVar n v) = object [n .= v]
1456
1173
1457−-- | ExposedPort represents a port (and it's type)
1174+-- | ExposedPorts represent a enumeraton of all the ports (and their type)
1458-- that a container should expose to other containers or the host system.
1175-- that a container should expose to other containers or the host system.
1459−-- `NOTE`: This does not automatically expose the port onto the host
1176+-- `NOTE`: This does not automatically expose the ports onto the host
1460−-- system but rather it just tags it. It's best to be used with
1177+-- system but rather it just tags them. It's best to be used with
1461-- the PublishAllPorts flag. It is also useful for
1178-- the PublishAllPorts flag. It is also useful for
1462-- the daemon to know which Environment variables to
1179-- the daemon to know which Environment variables to
1463-- inject into a container linking to our container.
1180-- inject into a container linking to our container.
1464-- Example linking a Postgres container named db would inject the following
1181-- Example linking a Postgres container named db would inject the following
1465-- environment variables automatically if we set the corresponding
1182-- environment variables automatically if we set the corresponding
1466−--
1183+-- ExposedPorts:
1467−-- ExposedPort:
1468−--
1469−-- @
1470-- DB_PORT_5432_TCP_PORT="5432"
1184-- DB_PORT_5432_TCP_PORT="5432"
1471-- DB_PORT_5432_TCP_PROTO="tcp"
1185-- DB_PORT_5432_TCP_PROTO="tcp"
1472-- DB_PORT_5432_TCP="tcp://172.17.0.1:5432"
1186-- DB_PORT_5432_TCP="tcp://172.17.0.1:5432"
1473−-- @
1474−data ExposedPort = ExposedPort Port PortType deriving (Eq, Show)
1187+newtype ExposedPorts = ExposedPorts (M.Map Port PortType) deriving (Eq, Show)
1188+-- JP: Should this be ExposedPorts [(Port, PortType)]?
1189+
1190+instance FromJSON ExposedPorts where
1191+ parseJSON (JSON.Object o) = do
1192+ ExposedPorts <$> HM.foldlWithKey' f (return M.empty) o
1475
1193
1476−instance {-# OVERLAPPING #-} FromJSON [ExposedPort] where
1477− parseJSON (JSON.Object o) = HM.foldlWithKey' f (return []) o
1478 where
1194 where
1479 f accM k _ = case T.split (== '/') k of
1195 f accM k _ = case T.split (== '/') k of
1480 [port', portType'] -> do
1196 [port', portType'] -> do
1481 port <- parseIntegerText port'
1197 port <- parseIntegerText port'
1482 portType <- parseJSON $ JSON.String portType'
1198 portType <- parseJSON $ JSON.String portType'
1483 acc <- accM
1199 acc <- accM
1484− return $ (ExposedPort port portType):acc
1200+ return $ M.insert port portType acc
1201+ _ ->
1485− _ -> fail "Could not parse ExposedPorts"
1202+ fail "Could not parse ExposedPorts"
1486− parseJSON (JSON.Null) = return []
1487− parseJSON _ = fail "ExposedPorts is not an object"
1203+ parseJSON _ = fail "ExposedPorts is not an object."
1488−
1489−instance {-# OVERLAPPING #-} ToJSON [ExposedPort] where
1490− toJSON [] = emptyJsonObject
1491− toJSON (p:ps) = toJsonKey (p:ps) key
1492− where key (ExposedPort p t) = show p <> slash <> show t
1493− slash = T.unpack "/"
1494
1204
1495−data Entrypoint = Entrypoint [T.Text] deriving (Eq, Show, Generic)
1496−
1497−instance ToJSON Entrypoint where
1205+instance ToJSON ExposedPorts where
1498− toJSON (Entrypoint (e:es)) = toJSON (e:es)
1206+ toJSON (ExposedPorts kvs) = object [((T.pack $ show p) <> "/" <> (T.pack $ show t)) .= JSON.Object HM.empty | (p,t) <- (M.toList kvs)]
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
1207
1509
1208
1510data ContainerConfig = ContainerConfig {
1209data ContainerConfig = ContainerConfig {
@@ -1514,7 +1213,7 @@ data ContainerConfig = ContainerConfig {
1514 , attachStdin :: Bool
1213 , attachStdin :: Bool
1515 , attachStdout :: Bool
1214 , attachStdout :: Bool
1516 , attachStderr :: Bool
1215 , attachStderr :: Bool
1517− , exposedPorts :: [ExposedPort]
1216+ , exposedPorts :: Maybe ExposedPorts -- Note: Should we expand the JSON instance and take away the Maybe?
1518 -- , publishService :: Text -- Don't see this in 1.24
1217 -- , publishService :: Text -- Don't see this in 1.24
1519 , tty :: Bool
1218 , tty :: Bool
1520 , openStdin :: Bool
1219 , openStdin :: Bool
@@ -1523,70 +1222,27 @@ data ContainerConfig = ContainerConfig {
1523 , cmd :: [Text]
1222 , cmd :: [Text]
1524 -- , argsEscaped :: Bool -- Don't see this in 1.24
1223 -- , argsEscaped :: Bool -- Don't see this in 1.24
1525 , image :: Text
1224 , image :: Text
1526− , volumes :: [Volume]
1225+ , volumes :: Maybe Volumes
1527 , workingDir :: Maybe FilePath
1226 , workingDir :: Maybe FilePath
1528− , entrypoint :: Entrypoint
1227+ , entrypoint :: Maybe Text -- Can be null?
1529 , networkDisabled :: Maybe Bool -- Note: Should we expand the JSON instance and take away the Maybe? Null is False?
1228 , networkDisabled :: Maybe Bool -- Note: Should we expand the JSON instance and take away the Maybe? Null is False?
1530 , macAddress :: Maybe Text
1229 , macAddress :: Maybe Text
1531 -- , onBuild :: Maybe Text -- For 1.24, only see this in the inspect response.
1230 -- , onBuild :: Maybe Text -- For 1.24, only see this in the inspect response.
1532− , labels :: [Label]
1231+ , labels :: Maybe Labels
1533 , stopSignal :: Signal
1232 , stopSignal :: Signal
1534 } deriving (Eq, Show, Generic)
1233 } deriving (Eq, Show, Generic)
1535
1234
1536−
1537instance ToJSON ContainerConfig where
1235instance ToJSON ContainerConfig where
1538 toJSON = genericToJSON defaultOptions {
1236 toJSON = genericToJSON defaultOptions {
1539 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
1237 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
1540
1238
1541instance FromJSON ContainerConfig where
1239instance FromJSON ContainerConfig where
1542− parseJSON (JSON.Object o) = do
1240+ parseJSON = genericParseJSON defaultOptions {
1543− hostname <- o .:? "Hostname"
1241+ fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}
1544− domainname <- o .:? "Domainname"
1545− user <- o .:? "User"
1546− attachStdin <- o .: "AttachStdin"
1547− attachStdout <- o .: "AttachStdout"
1548− attachStderr <- o .: "AttachStderr"
1549− exposedPorts <- o .:? "ExposedPorts" .!= []
1550− tty <- o .: "Tty"
1551− openStdin <- o .: "OpenStdin"
1552− stdinOnce <- o .: "StdinOnce"
1553− env <- o .: "Env"
1554− cmd <- o .: "Cmd"
1555− image <- o .: "Image"
1556− volumes <- o .: "Volumes"
1557− workingDir <- o .:? "WorkingDir"
1558− entrypoint <- o .: "Entrypoint"
1559− networkDisabled <- o .:? "networkDisabled"
1560− macAddress <- o .:? "MacAddress"
1561− labels <- o .:? "Labels" .!= []
1562− stopSignal <- o .: "StopSignal"
1563− return $ ContainerConfig hostname domainname user attachStdin attachStdout attachStderr exposedPorts tty openStdin stdinOnce env cmd image volumes workingDir entrypoint networkDisabled
1564− macAddress labels stopSignal
1565− parseJSON _ = fail "NetworkSettings is not an object."
1566
1242
1567−#if MIN_VERSION_base(4,13,0)
1568−parseIntegerText :: (MonadFail m) => Text -> m Integer
1569−#else
1570parseIntegerText :: (Monad m) => Text -> m Integer
1243parseIntegerText :: (Monad m) => Text -> m Integer
1571−#endif
1572parseIntegerText t = case readMaybe $ T.unpack t of
1244parseIntegerText t = case readMaybe $ T.unpack t of
1573 Nothing ->
1245 Nothing ->
1574 fail "Could not parse Integer"
1246 fail "Could not parse Integer"
1575 Just i ->
1247 Just i ->
1576 return i
1248 return i
1577−
1578−-- | Helper function for converting a data type [a] to a json dictionary
1579−-- like so {"something": {}, "something2": {}}
1580−toJsonKey :: Foldable t => t a -> (a -> String) -> JSON.Value
1581−toJsonKey vs getKey = JSON.Object $ foldl f HM.empty vs
1582− where f acc x = HM.insert (T.pack $ getKey x) (JSON.Object HM.empty) acc
1583−
1584−-- | Helper function for converting a data type [a] to a json dictionary
1585−-- like so {"something": "val1", "something2": "val2"}
1586−toJsonKeyVal :: (Foldable t, JSON.ToJSON r) => t a -> (a -> String) -> (a -> r) -> JSON.Value
1587−toJsonKeyVal vs getKey getVal = JSON.Object $ foldl f HM.empty vs
1588− where f acc x = HM.insert (T.pack $ getKey x) (toJSON $ getVal x) acc
1589−
1590−-- | Helper function that return an empty dictionary "{}"
1591−emptyJsonObject :: JSON.Value
1592−emptyJsonObject = JSON.Object HM.empty
src/Docker/Client/Utils.hsdeleted−131
@@ -1,131 +0,0 @@
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.yamldeleted−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-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.yamldeleted−4
@@ -1,4 +0,0 @@
1−resolver: lts-9.4
2−packages:
3−- '.'
4−extra-deps: []
stack-8.0.yamldeleted−5
@@ -1,5 +0,0 @@
1−resolver: lts-7.12
2−packages:
3−- '.'
4−extra-deps:
5−- unliftio-core-0.1.1.0
stack-8.6.4.yamldeleted−4
@@ -1,4 +0,0 @@
1−resolver: lts-13.19
2−packages:
3−- '.'
4−extra-deps: []
stack-8.8.2.yamldeleted−5
@@ -1,5 +0,0 @@
1−resolver: lts-15.0
2−packages:
3−- '.'
4−extra-deps: []
5−
stack.yamlmode 120000 → 100644+32−1
@@ -1 +0,0 @@
1−stack-8.6.4.yaml
@@ -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-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]
tests/Dockerfile+1−1
@@ -1,4 +1,4 @@
1FROM debian:jessie
1FROM debian:jessie
2
2
3−CMD ["/bin/bash", "-c", "echo $TEST"]
3+CMD ["/bin/bash", "-c", "echo 123"]
4
4
tests/tests.hs+53−239
@@ -2,8 +2,6 @@
2
2
3module Main where
3module Main where
4
4
5−import Data.Either (rights)
6−import Prelude hiding (all)
7import qualified Test.QuickCheck.Monadic as QCM
5import qualified Test.QuickCheck.Monadic as QCM
8import Test.Tasty
6import Test.Tasty
9import Test.Tasty.HUnit
7import Test.Tasty.HUnit
@@ -11,284 +9,100 @@ import Test.Tasty.QuickCheck (testProperty)
11
9
12import Control.Concurrent (threadDelay)
10import Control.Concurrent (threadDelay)
13import Control.Lens ((^.), (^?))
11import Control.Lens ((^.), (^?))
14−import Control.Monad (forM_)
15import Control.Monad.IO.Class
12import Control.Monad.IO.Class
16import Control.Monad.Trans.Class (lift)
13import Control.Monad.Trans.Class (lift)
17import qualified Data.Aeson as JSON
14import qualified Data.Aeson as JSON
18−import Data.Aeson ((.=))
15+import Data.Aeson.Lens (key, _Object, _String, _Value)
19−import Data.Aeson.Lens (key, _Array, _Null, _Object,
20− _String, _Value)
21import qualified Data.ByteString as B
16import qualified Data.ByteString as B
22import qualified Data.ByteString.Char8 as C
17import qualified Data.ByteString.Char8 as C
23import qualified Data.ByteString.Lazy as BL
18import qualified Data.ByteString.Lazy as BL
24import qualified Data.HashMap.Strict as HM
19import qualified Data.HashMap.Strict as HM
25import Data.Int (Int)
20import Data.Int (Int)
26import qualified Data.Map as M
21import qualified Data.Map as M
27−import Data.Maybe (fromJust, isJust, isNothing, listToMaybe)
22+import Data.Maybe (fromJust, isJust)
28import Data.Monoid
23import Data.Monoid
29import Data.Text (Text, unpack)
24import Data.Text (Text, unpack)
30−import qualified Data.Vector as V
31import Network.Connection (TLSSettings (..))
25import Network.Connection (TLSSettings (..))
32import Network.HTTP.Client (newManager)
26import Network.HTTP.Client (newManager)
33import Network.HTTP.Client.TLS
27import Network.HTTP.Client.TLS
34import Network.HTTP.Types.Status
28import Network.HTTP.Types.Status
35−import System.Directory (getCurrentDirectory)
36−import System.Environment (lookupEnv)
37import System.Process (system)
29import System.Process (system)
38
30
39import Docker.Client
31import Docker.Client
40
32
41-- opts = defaultClientOpts
33-- opts = defaultClientOpts
34+
42−testImageName = "docker-hs/test"
35+testImageName = "docker-hs-test"
43−imageToDeleteFullName = "hello-world:latest"
44
36
45toStrict1 = B.concat . BL.toChunks
37toStrict1 = B.concat . BL.toChunks
46
38
47−runDocker f
39+runDocker f = do
48− -- let opts = defaultClientOpts {baseUrl = "https://127.0.0.1:2376/"}
40+ -- let opts = defaultClientOpts {baseUrl = "https://127.0.0.1:2376/"}
49− -- params' <- clientParamsWithClientAuthentication "127.0.0.1" 2376 "~/.docker/test-client-key.pem" "~/.docker/test-client-cert.pem" >>= fromRight
41+ -- params' <- clientParamsWithClientAuthentication "127.0.0.1" 2376 "~/.docker/test-client-key.pem" "~/.docker/test-client-cert.pem" >>= fromRight
50− -- params <- clientParamsSetCA params' "~/.docker/test-ca.pem"
42+ -- params <- clientParamsSetCA params' "~/.docker/test-ca.pem"
51− -- let settings = mkManagerSettings (TLSSettings params) Nothing
43+ -- let settings = mkManagerSettings (TLSSettings params) Nothing
52− -- mgr <- newManager settings
44+ -- mgr <- newManager settings
53− = do
54− h <- defaultHttpHandler
55− runDockerT (defaultClientOpts, h) f
45+ runDockerT (defaultClientOpts, defaultHttpHandler) f
56
46
57testDockerVersion :: IO ()
47testDockerVersion :: IO ()
58−testDockerVersion =
48+testDockerVersion = runDocker $ do
59− runDocker $
60− do v <- getDockerVersion
49+ v <- getDockerVersion
61− lift $ assert $ isRight v
50+ lift $ assert $ isRight v
62−
63−testStopNonexisting :: IO ()
64−testStopNonexisting = runDocker $ do
65− res <- stopContainer DefaultTimeout $ fromJust $ toContainerID "thisshouldnotexist"
66− lift $ assert $ isLeft res
67
51
68testFindImage :: IO ()
52testFindImage :: IO ()
69−testFindImage =
53+testFindImage = runDocker $ do
70− runDocker $
71− do images <- listImages defaultListOpts >>= fromRight
54+ images <- listImages defaultListOpts >>= fromRight
72− let xs = filter (elem imageFullName . imageRepoTags) images
55+ let x = filter ((== [testImageName<>":latest"]) . imageRepoTags) images
73− lift $ assert $ length xs == 1
56+ lift $ assert $ length x == 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
87− images <- listImages defaultListOpts >>= fromRight
88− return $ listToMaybe
89− $ filter (elem imageToDeleteFullName . imageRepoTags) images
90−
91−testListContainers :: IO ()
92−testListContainers =
93− runDocker $
94− do containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing
95− c <- fromRight containerId
96− res <- listContainers $ ListOpts { all=True }
97− deleteContainer (ContainerDeleteOpts True True) c
98− lift $ assert $ isRight res
99−
100−testBuildFromDockerfile :: IO ()
101−testBuildFromDockerfile = do
102− cur <- getCurrentDirectory
103− let ctxDir = cur ++ "/tests"
104− runDocker $ do
105− r <- buildImageFromDockerfile (defaultBuildOpts "docker-hs/dockerfile-test") ctxDir
106− lift $ assert $ isRight r
107−
108
57
109testRunAndReadLog :: IO ()
58testRunAndReadLog :: IO ()
110−testRunAndReadLog = testRunAndReadLogHelper $ NetworkingConfig HM.empty
59+testRunAndReadLog = runDocker $ do
111−
60+ containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest"))
112−testRunAndReadLogWithNetworking :: IO ()
113−testRunAndReadLogWithNetworking = testRunAndReadLogHelper $ NetworkingConfig $ HM.fromList [("test-network", EndpointConfig ["cellar-door"])]
114−
115−testRunAndReadLogHelper :: NetworkingConfig -> IO ()
116−testRunAndReadLogHelper networkingConfig =
117− runDocker $
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
121− c <- fromRight containerId
61+ c <- fromRight containerId
122− status1 <- startContainer defaultStartOpts c
62+ status1 <- startContainer defaultStartOpts c
123− _ <- inspectContainer c >>= fromRight
63+ _ <- inspectContainer c >>= fromRight
124− lift $ threadDelay 300000 -- give 300ms for the application to finish
64+ lift $ threadDelay 300000 -- give 300ms for the application to finish
125− lift $ assertBool ("starting the container, unexpected status: " ++ show status1) $ isRightUnit status1
65+ lift $ assert $ status1 == Right ()
66+ status2 <- killContainer SIGTERM c
126− logs <- getContainerLogs defaultLogOpts c >>= fromRight
67+ logs <- getContainerLogs defaultLogOpts c >>= fromRight
68+ lift $ assert $ status2 == Right ()
127− lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
69+ lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)
128− status3 <- deleteContainer (ContainerDeleteOpts True True) c
70+ status3 <- deleteContainer (DeleteOpts True True) c
129− lift $ assertBool ("deleting container, unexpected status: " ++ show status3) $ isRightUnit status3
71+ lift $ assert $ status3 == Right ()
130− mapM_ removeNetwork createdNetworks
72+
73+
74+sampleEP = ExposedPorts $ M.fromList [(80, TCP), (1337, UDP)]
75+
76+testExposedPorts :: TestTree
77+testExposedPorts = testGroup "Testing ExposedPorts JSON" [ testTCP, testUDP ]
131− where
78+ where
132− isRightUnit (Right ()) = True
79+ testTCP = testCase "tcp port" $ assert $ JSON.toJSON sampleEP ^. key "80/tcp" . _Object == HM.empty
133− isRightUnit _ = False
80+ testUDP = testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty
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
146
81
147−testLogDriverOptionsJson :: TestTree
148−testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [test1, test2, test3]
149− where
150− test1 = testCase "Driver option 1" $ assert $ JSON.toJSON sample ^. key key1 . _String == val1
151− test2 = testCase "Driver option 2" $ assert $ JSON.toJSON sample ^. key key2 . _String == val2
152− test3 =
153− testCase "Test override" $ assert $ JSON.toJSON sample2 ^. key key1 . _String == "override"
154− sample = [LogDriverOption key1 val1, LogDriverOption key2 val2]
155− sample2 = [LogDriverOption key1 val1, LogDriverOption key1 "override"]
156− key1 = "some-key"
157− val1 = "some-val"
158− key2 = "some-key2"
159− val2 = "some-key2"
160−
161−testExposedPortsJson :: TestTree
162−testExposedPortsJson = testGroup "Testing ExposedPorts JSON" [testTCP, testUDP]
163− where
164− testTCP = testCase "tcp port" $ assert $ JSON.toJSON sampleEP ^. key "80/tcp" . _Object == HM.empty
165− testUDP =
166− testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty
167− sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP]
168−
169−testLabelsJson :: TestTree
170−testLabelsJson = testGroup "Testing Labels JSON" [testLS1, testLS2, testOverride]
171− where
172− testLS1 = testCase "test label key1" $ assert $ JSON.toJSON sampleLS ^. key key1 . _String == val1
173− testLS2 = testCase "test label key2" $ assert $ JSON.toJSON sampleLS ^. key key2 . _String == val2
174− testOverride =
175− testCase "test label override" $ assert $ JSON.toJSON [Label key1 val1, Label key1 "override"] ^.
176− key key1 .
177− _String ==
178− "override"
179− sampleLS = [Label key1 val1, Label key2 val2]
180− key1 = "com.example.some-label"
181− val1 = "some-value"
182− key2 = "something"
183− val2 = "value"
184−
185−testVolumesJson :: TestTree
186−testVolumesJson = testGroup "Testing Volumes JSON" [testSample1, testSample2]
187− where
188− testSample1 =
189− testCase "Test exposing volume: /tmp" $ assert $ JSON.toJSON sampleVolumes ^. key "/tmp" . _Object ==
190− HM.empty
191− testSample2 =
192− testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON sampleVolumes ^. key "/opt" . _Object ==
193− HM.empty
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− ]
238
82
239integrationTests :: TestTree
83integrationTests :: TestTree
240−integrationTests =
84+integrationTests = testGroup "Integration Tests" [
241− testGroup
242− "Integration Tests"
243− [ testCase "Get docker version" testDockerVersion
85+ testCase "Get docker version" testDockerVersion,
244− , testCase "Build image from Dockerfile" testBuildFromDockerfile
245− , testCase "Find image by name" testFindImage
86+ testCase "Find image by name" testFindImage,
246− , testCase "Delete image" testDeleteImage
247− , testCase "List containers" testListContainers
248− , testCase "Run a dummy container and read its log" testRunAndReadLog
87+ 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− ]
253
88
254jsonTests :: TestTree
89jsonTests :: TestTree
255−jsonTests =
90+jsonTests = testGroup "JSON Tests" [testExposedPorts]
256− testGroup
257− "JSON Tests"
258− [ testExposedPortsJson
259− , testVolumesJson
260− , testLabelsJson
261− , testLogDriverOptionsJson
262− , testEntrypointJson
263− , testEnvVarJson
264− , testNetworkingConfigJson
265− ]
266
91
267setup :: IO ()
92setup :: IO ()
268−setup =
269− mapM_ system
270− [ "docker pull " ++ unpack imageToDeleteFullName
271− , "docker build -t " ++ unpack testImageName ++ " tests"
93+setup = system ("docker build -t "++unpack testImageName++" tests") >> return ()
272− ]
273
94
274−isLeft = not . isRight
275−
276−isRight (Left _) = False
95+isRight (Left _) = False
277isRight (Right _) = True
96isRight (Right _) = True
278
97
279−fromRight
280− :: (MonadIO m, Show l)
98+fromRight :: (MonadIO m, Show l) => Either l r -> m r
281− => Either l r -> m r
282fromRight (Left l) = do
99fromRight (Left l) = do
283− liftIO $ assertFailure $ "Left: " ++ show l
100+ liftIO $ assertFailure $ "Left: " ++ show l
284− undefined
101+ undefined
285fromRight (Right r) = return r
102fromRight (Right r) = return r
286
103
287main :: IO ()
104main :: IO ()
288main = do
105main = do
289− stackage <- lookupEnv "RUN_INTEGRATION_TESTS"
290− case stackage of
291− Nothing -> defaultMain $ testGroup "Tests" [jsonTests]
292− Just _ -> do
293− setup
106+ setup
294− defaultMain $ testGroup "Tests" [jsonTests, integrationTests]
107+ defaultMain $ testGroup "Tests" [jsonTests, integrationTests]
108+