67df577...master · docker-hs

git.iko.soy/docker-hs

on master help sign in

.gitignore+1

since splitsnapshots

unifiedsplit

@@ -4,3 +4,4 @@

4*~

5.stack-work/

6dist-newstyle

7+/cabal.project.local

.travis.yml+25−3

@@ -22,8 +22,30 @@ services:

22 - docker

24env:

25− - GHCVER=7.10 STACK_ARGS=""

25+ global:

26− - GHCVER=8.0 STACK_ARGS=""

26+ - RUN_INTEGRATION_TESTS=1

27+ - STACK_ARGS=""

28+

29+ matrix:

30+ - DOCKER_VERSION="1.12.3-0~trusty" GHCVER=7.10

31+ - DOCKER_VERSION="1.13.1-0~ubuntu-trusty" GHCVER=7.10

32+ - DOCKER_VERSION="17.05.0~ce-0~ubuntu-trusty" GHCVER=7.10

33+

34+ - DOCKER_VERSION="1.12.3-0~trusty" GHCVER=8.0

35+ - DOCKER_VERSION="1.13.1-0~ubuntu-trusty" GHCVER=8.0

36+ - DOCKER_VERSION="17.05.0~ce-0~ubuntu-trusty" GHCVER=8.0

37+

38+ - DOCKER_VERSION="1.12.3-0~trusty" GHCVER=8.0.2

39+ - DOCKER_VERSION="1.13.1-0~ubuntu-trusty" GHCVER=8.0.2

40+ - DOCKER_VERSION="17.05.0~ce-0~ubuntu-trusty" GHCVER=8.0.2

41+

42+ - DOCKER_VERSION="1.12.3-0~trusty" GHCVER=8.6.4

43+ - DOCKER_VERSION="1.13.1-0~ubuntu-trusty" GHCVER=8.6.4

44+ - DOCKER_VERSION="17.05.0~ce-0~ubuntu-trusty" GHCVER=8.6.4

45+

46+ - DOCKER_VERSION="1.12.3-0~trusty" GHCVER=8.8.2

47+ - DOCKER_VERSION="1.13.1-0~ubuntu-trusty" GHCVER=8.8.2

48+ - DOCKER_VERSION="17.05.0~ce-0~ubuntu-trusty" GHCVER=8.8.2

28addons:

50addons:

29 apt:

51 apt:

@@ -35,7 +57,7 @@ before_install:

35 - sudo sh -c 'echo "deb https://apt.dockerproject.org/repo ubuntu-trusty main" > /etc/apt/sources.list.d/docker.list'

57 - sudo sh -c 'echo "deb https://apt.dockerproject.org/repo ubuntu-trusty main" > /etc/apt/sources.list.d/docker.list'

36 - sudo apt-key adv --keyserver hkp://p80.pool.sks-keyservers.net:80 --recv-keys 58118E89F3A912897C070ADBF76221572C52609D

58 - sudo apt-key adv --keyserver hkp://p80.pool.sks-keyservers.net:80 --recv-keys 58118E89F3A912897C070ADBF76221572C52609D

37 - sudo apt-get update

59 - sudo apt-get update

38− - sudo apt-get -qqy -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confold" install docker-engine=1.12.3-0~trusty

60+ - sudo apt-get -qqy -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confold" install docker-engine=$DOCKER_VERSION

40install:

62install:

41 - mkdir -p "$HOME"/.local/bin

63 - mkdir -p "$HOME"/.local/bin

CHANGELOG.md+71

@@ -1,5 +1,76 @@

1# CHANGELOG

3+## 0.6.0.3 (2020-02-17)

5+- Support for ghc 8.8.2.

6+- Bump dependency version.

7+- Use MonadFail for later versions.

9+## 0.6.0.1 (2019-05-23)

10+

11+- Support ghc 8.6.4.

12+- Bump containers version.

13+

14+## 0.6.0.0 (2018-06-28)

15+

16+- Rename DeleteOpts to ContainerDeleteOpts.

17+- Implement image deletion.

18+- Bump aeson version.

19+- Implement network aliases.

20+- Implement creating/deleting networks.

21+

22+## 0.5.1.1 (2018-03-09)

23+

24+- Bump aeson version.

25+

26+## 0.5.1.0 (2018-02-23)

27+

28+- Support http-conduit-2.3.0.

29+- Bump http-types versions.

30+

31+## 0.5.0.1 (2018-01-26)

32+

33+- Bumps upper bound for http-types (properly this time).

34+

35+## 0.5.0.0 (2018-01-24)

36+

37+- Added (some) contribution and general docs

38+- Fix case when stopping non-existent container

39+- Added more integration tests

40+- Fixed error while parsing list container endpoint output

41+- Changed State/Status data type (related to the above fix)

42+- Added tests against different docker version to travis CIA

43+- Fixed EnvVar JSON encoding

44+- Fixed NetworkMode parsing

45+- Allow http-types 0.11

46+

47+## 0.4.1.1 (2017-10-16)

48+

49+- Small change to add env var for skipping integration tests.

50+ This is mostly to avoid running those on stackage.

51+

52+## 0.4.1.0 (2017-10-04)

53+

54+- Relaxed aeson, tls and time upper bounds

55+

56+

57+## 0.4.0.2 (2017-09-19)

58+

59+- Support LTS 9.4

60+

61+## 0.4.0.1 (2017-06-29)

62+

63+- fixes omKillDisable parsing from json

64+- adds Entrypoint data type and tests edge cases

65+- more tests

66+- small comsmetic changes

67+

68+## 0.4.0.0 (2017-03-20)

69+

70+- Adds streaming support via conduits (changes API a bit hence the major version release)

71+- Added support for streaming log output

72+- Added support for pulling images from the hub (and streaming the output)

73+

3## 0.3.0.1 (2016-09-07)

74## 0.3.0.1 (2016-09-07)

5- Small cosmetic changes and marking OVERLAPPING instance

76- Small cosmetic changes and marking OVERLAPPING instance

CONTRIBUTING.md+12−2

@@ -1,4 +1,14 @@

1−# TODO

1+# Contributing

3−Add basic guidelines here, things like style guide (using .configuration files from the repo) etc etc.

3+If you wish to contribute please see [any issue on GitHub tagged with "help

4+wanted"](https://github.com/denibertovic/docker-hs/issues?q=is%3Aopen+is%3Aissue+label%3A%22help+wanted%22).

5+Before starting to work, consider commenting on the issue you want to resolve or

6+open a new issue to discuss design decisions and implementation details. This is

7+so that no development cycles go to waste on implementing a feature that might

8+not get merged either because of implementation details or other reasons.

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 @@

3All rights reserved.

Makefile+21−2

@@ -1,4 +1,6 @@

1−.PHONY: build repl test release

1+.PHONY: build repl test release help

3+.DEFAULT_GOAL = help

3PROJECT_NAME ?= $(shell grep "^name" docker.cabal | cut -d " " -f17)

5PROJECT_NAME ?= $(shell grep "^name" docker.cabal | cut -d " " -f17)

4VERSION ?= $(shell grep "^version:" docker.cabal | cut -d " " -f14)

6VERSION ?= $(shell grep "^version:" docker.cabal | cut -d " " -f14)

@@ -6,18 +8,35 @@ RESOLVER ?= $(shell grep "^resolver:" stack.yaml | cut -d " " -f2)

6GHC_VERSION ?= $(shell stack ghc -- --version | cut -d " " -f8)

8GHC_VERSION ?= $(shell stack ghc -- --version | cut -d " " -f8)

7ARCH=$(shell uname -m)

9ARCH=$(shell uname -m)

11+## Run build

9build:

12build:

10 @stack build

13 @stack build

15+## Run repl

12repl:

16repl:

13 @stack repl

17 @stack repl

19+## Run tests. Example RUN_INTEGRATION_TESTS=1 make test

15test:

20test:

16− @stack test

21+ @RUN_INTEGRATION_TESTS=1 stack test

23+## Cut new release

18release:

24release:

19 @stack build --haddock

25 @stack build --haddock

20 @stack sdist

26 @stack sdist

21 @echo "\n\nDone. Now run: \n\nstack upload <path_to_tarball>\n"

27 @echo "\n\nDone. Now run: \n\nstack upload <path_to_tarball>\n"

22 @echo "\nAnd: \n\ngit tag ${VERSION} && git push --tags\n"

28 @echo "\nAnd: \n\ngit tag ${VERSION} && git push --tags\n"

30+## Show help screen.

31+help:

32+ @echo "Please use \`make <target>' where <target> is one of\n\n"

33+ @awk '/^[a-zA-Z\-\_0-9]+:/ { \

34+ helpMessage = match(lastLine, /^## (.*)/); \

35+ if (helpMessage) { \

36+ helpCommand = substr($$1, 0, index($$1, ":")-1); \

37+ helpMessage = substr(lastLine, RSTART + 3, RLENGTH); \

38+ printf "%-30s %s\n", helpCommand, helpMessage; \

39+ } \

40+ } \

41+ { lastLine = $$0 }' $(MAKEFILE_LIST)

42+

README.md+34−6

@@ -7,14 +7,42 @@

8## Current state

10−**API is still not stable.**

10+Supported Docker Engine Api version: `v1.24` and onwards.

11+

12+Anything upward of that should work since Docker versions their API.

13+Older docker version and engine api versions are not supported at the moment.

14+

15+## Documentation

16+

17+The API-documentation is available at

18+[Hackage](https://hackage.haskell.org/package/docker). There are also some

19+usage-examples in the main library source file,

20+[`Client.hs`](https://hackage.haskell.org/package/docker/docs/Docker-Client.html).

12## Contributing

22## Contributing

14−If you wish to contribute please see any issue tagged with "help wanted".

24+Please see [CONTRIBUTING.md](CONTRIBUTING.md).

15−Make sure to submit your PR's against the `master` branch.

25+

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`.

17−Please consider filling an Issue first and discuss design decisions and implementation details before

45+## IRC

18−writing any code. This is so that no development cycles go to waste on implementing a feature that

19−might not get merged either because of implementation details or other reasons.

47+If you have any questions or suggestions you can find the maintainers in `#docker-haskell`

48+on freenode.

docker.cabal+26−12

@@ -1,5 +1,5 @@

1name: docker

2−version: 0.3.0.1

2+version: 0.6.0.3

3synopsis: An API client for docker written in Haskell

4description: See API documentation below.

5homepage: https://github.com/denibertovic/docker-hs

@@ -14,24 +14,29 @@ extra-source-files: README.md

14cabal-version: >=1.10

15stability: experimental

17+-- Flag small-http-conduit

18+-- Description: Resolve whether http-conduit < 2.3.0.

19+-- Manual: False

20+-- Default: True

21+

17library

22library

18− default-extensions: DeriveGeneric, OverloadedStrings, ScopedTypeVariables, ExplicitForAll, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes, DeriveFunctor, FlexibleInstances

23+ default-extensions: DeriveGeneric, OverloadedStrings, ScopedTypeVariables, ExplicitForAll, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes, DeriveFunctor, FlexibleInstances, CPP

19 hs-source-dirs: src

24 hs-source-dirs: src

20 exposed-modules: Docker.Client, Docker.Client.Api, Docker.Client.Types, Docker.Client.Internal, Docker.Client.Http, Docker.Client.Utils

25 exposed-modules: Docker.Client, Docker.Client.Api, Docker.Client.Types, Docker.Client.Internal, Docker.Client.Http, Docker.Client.Utils

21 -- other-modules: Docker.Internal

26 -- other-modules: Docker.Internal

22 build-depends: base >= 4.7 && < 5

27 build-depends: base >= 4.7 && < 5

23− , aeson >= 0.9.0 && < 1.1.0

28+ , aeson >= 0.9.0 && < 2.0.0

24 , blaze-builder >= 0.4.0 && < 0.5.0

29 , blaze-builder >= 0.4.0 && < 0.5.0

25 , bytestring >= 0.10.0 && < 0.11.0

30 , bytestring >= 0.10.0 && < 0.11.0

26− , containers >= 0.5.0 && < 0.6.0

31+ , containers >= 0.5.0 && < 0.7.0

27 , data-default-class >= 0.0.1 && < 0.2.0

32 , data-default-class >= 0.0.1 && < 0.2.0

28− , http-client >= 0.4.0 && < 0.5.0

33+ , http-client >= 0.4.0 && < 0.7.0

29− , http-types >= 0.9 && < 0.10.0

34+ , http-types >= 0.9 && < 0.13

35+ , vector

30 , conduit

36 , conduit

31 , conduit-combinators

37 , conduit-combinators

32 , conduit-extra

38 , conduit-extra

33 , exceptions

39 , exceptions

34− , http-conduit

35 , monad-control

40 , monad-control

36 , resourcet

41 , resourcet

37 , transformers

42 , transformers

@@ -46,13 +51,20 @@ library

46 , mtl >= 2.0.0 && < 3.0.0

51 , mtl >= 2.0.0 && < 3.0.0

47 , network >= 2.6.0

52 , network >= 2.6.0

48 , text >= 1.0.0 && < 2.0.0

53 , text >= 1.0.0 && < 2.0.0

49− , time >= 1.5.0 && < 1.7.0

54+ , time >= 1.5.0 && < 2.0.0

50 , scientific >= 0.3.0 && < 0.4.0

55 , scientific >= 0.3.0 && < 0.4.0

51− , tls >= 1.3.7 && < 1.4.0

56+ , tls >= 1.3.7 && < 1.6.0

52 , unordered-containers >= 0.2.0 && < 0.3.0

57 , unordered-containers >= 0.2.0 && < 0.3.0

53− , x509 >= 1.6.0 && < 1.7.0

58+ , x509 >= 1.6.0 && < 1.8.0

54− , x509-store >= 1.6.0 && < 1.7.0

59+ , x509-store >= 1.6.0 && < 1.8.0

55− , x509-system >= 1.6.0 && < 1.7.0

60+ , x509-system >= 1.6.0 && < 1.8.0

61+ , http-conduit

62+ , unliftio-core >= 0.1.0.0 && < 0.2.0

63+ -- if flag(small-http-conduit)

64+ -- build-depends: http-conduit < 2.3.0

65+ -- else

66+ -- build-depends: http-conduit >= 2.3.0

67+ -- , unliftio-core

56 default-language: Haskell2010

68 default-language: Haskell2010

57 ghc-options: -Wall -fno-warn-name-shadowing

69 ghc-options: -Wall -fno-warn-name-shadowing

@@ -61,6 +73,7 @@ test-suite docker-hs-tests

61 , bytestring

73 , bytestring

62 , connection

74 , connection

63 , docker

75 , docker

76+ , directory

64 , aeson

77 , aeson

65 , containers

78 , containers

66 , unordered-containers

79 , unordered-containers

@@ -76,6 +89,7 @@ test-suite docker-hs-tests

76 , transformers

89 , transformers

77 , QuickCheck

90 , QuickCheck

78 , process

91 , process

92+ , vector

79 type: exitcode-stdio-1.0

93 type: exitcode-stdio-1.0

80 main-is: tests.hs

94 main-is: tests.hs

81 hs-source-dirs: tests

95 hs-source-dirs: tests

examples/Example.hs+52−43

@@ -1,55 +1,64 @@

1import Docker.Client

3runNginxContainer :: IO ContainerID

4+runNginxContainer = do

5+ h <- defaultHttpHandler

4−runNginxContainer = runDockerT (defaultClientOpts, defaultHttpHandler) $ do

6+ runDockerT (defaultClientOpts, h) $

5− let pb = PortBinding 80 TCP [HostPort "0.0.0.0" 8000]

7+ do let pb = PortBinding 80 TCP [HostPort "0.0.0.0" 8000]

6− let myCreateOpts = addPortBinding pb $ defaultCreateOpts "nginx:latest"

8+ let myCreateOpts = addPortBinding pb $ defaultCreateOpts "nginx:latest"

7− cid <- createContainer myCreateOpts (Just "myNginxContainer")

9+ cid <- createContainer myCreateOpts (Just "myNginxContainer")

8− case cid of

10+ case cid of

9− Left err -> error $ show err

11+ Left err -> error $ show err

10− Right i -> do

12+ Right i -> do

11− _ <- startContainer defaultStartOpts i

13+ _ <- startContainer defaultStartOpts i

12− return i

14+ return i

14stopNginxContainer :: ContainerID -> IO ()

16stopNginxContainer :: ContainerID -> IO ()

17+stopNginxContainer cid = do

18+ h <- defaultHttpHandler

15−stopNginxContainer cid = runDockerT (defaultClientOpts, defaultHttpHandler) $ do

19+ runDockerT (defaultClientOpts, h) $

16− r <- stopContainer DefaultTimeout cid

20+ do r <- stopContainer DefaultTimeout cid

17− case r of

21+ case r of

18− Left _ -> error "I failed to stop the container"

22+ Left _ -> error "I failed to stop the container"

19− Right _ -> return ()

23+ Right _ -> return ()

21runPostgresContainer :: IO ContainerID

25runPostgresContainer :: IO ContainerID

26+runPostgresContainer = do

27+ h <- defaultHttpHandler

22−runPostgresContainer = runDockerT (defaultClientOpts, defaultHttpHandler) $ do

28+ runDockerT (defaultClientOpts, h) $

23− let pb = PortBinding 5432 TCP [HostPort "0.0.0.0" 5432]

29+ do let pb = PortBinding 5432 TCP [HostPort "0.0.0.0" 5432]

24− let b = Bind "/tmp" "/tmp" Nothing

30+ let b = Bind "/tmp" "/tmp" Nothing

25− let myCreateOpts = addBind b $ addPortBinding pb $ defaultCreateOpts "postgres:9.5"

31+ let myCreateOpts = addBind b $ addPortBinding pb $ defaultCreateOpts "postgres:9.5"

26− cid <- createContainer myCreateOpts Nothing

32+ cid <- createContainer myCreateOpts Nothing

27− case cid of

33+ case cid of

28− Left err -> error $ show err

34+ Left err -> error $ show err

29− Right i -> do

35+ Right i -> do

30− _ <- startContainer defaultStartOpts i

36+ _ <- startContainer defaultStartOpts i

31− return i

37+ return i

33-- | Example of how we can start a database container while hosting it's

39-- | Example of how we can start a database container while hosting it's

34-- data in a data volume living inside another container.

40-- data in a data volume living inside another container.

35runPostgresWithDataContainer :: IO ContainerID

41runPostgresWithDataContainer :: IO ContainerID

36−runPostgresWithDataContainer = runDockerT (defaultClientOpts, defaultHttpHandler) $ do

42+runPostgresWithDataContainer = do

43+ h <- defaultHttpHandler

44+ runDockerT (defaultClientOpts, h) $

37− -- We use a dummy command like /bin/true because we don't want to start

45+ -- We use a dummy command like /bin/true because we don't want to start

38− -- the postgres database in the data container we just want it to

46+ -- the postgres database in the data container we just want it to

39− -- create a container filesystem for us.

47+ -- create a container filesystem for us.

40− let dataOpts = setCmd "/bin/true" $ defaultCreateOpts "postgres:9.5"

48+ do let dataOpts = setCmd "/bin/true" $ defaultCreateOpts "postgres:9.5"

41− cid <- createContainer dataOpts (Just "myDataContainer")

49+ cid <- createContainer dataOpts (Just "myDataContainer")

50+ _ <-

42− _ <- case cid of

51+ case cid of

43− Left err -> error $ show err

52+ Left err -> error $ show err

44− Right i -> startContainer defaultStartOpts i

53+ Right i -> startContainer defaultStartOpts i

45− let pb = PortBinding 5432 TCP [HostPort "0.0.0.0" 5432]

54+ let pb = PortBinding 5432 TCP [HostPort "0.0.0.0" 5432]

46− -- Default permission is read-write if we don't specify anything

55+ -- Default permission is read-write if we don't specify anything

47− let vf = VolumeFrom "myDataContainer" Nothing

56+ let vf = VolumeFrom "myDataContainer" Nothing

48− let myCreateOpts = addVolumeFrom vf $ addPortBinding pb $ defaultCreateOpts "postgres:9.5"

57+ let myCreateOpts = addVolumeFrom vf $ addPortBinding pb $ defaultCreateOpts "postgres:9.5"

49− ccid <- createContainer myCreateOpts (Just "pgContainer")

58+ ccid <- createContainer myCreateOpts (Just "pgContainer")

50− case ccid of

59+ case ccid of

51− Left err -> error $ show err

60+ Left err -> error $ show err

52− Right i -> do

61+ Right i -> do

53− _ <- startContainer defaultStartOpts i

62+ _ <- startContainer defaultStartOpts i

54− return i

63+ return i

src/Docker/Client.hs+12−5

@@ -3,7 +3,7 @@

4{-|

5Module : Docker.Client

6−Copyright : (c) Deni Bertovic, 2016

6+Copyright : (c) Deni Bertovic, 2014

7License : BSD3

8Maintainer : deni@denibertovic.com

9Stability : experimental

@@ -20,7 +20,9 @@ the host.

20import Docker.Client

22runNginxContainer :: IO ContainerID

23+runNginxContainer = do

24+ h <- defaultHttpHandler

23−runNginxContainer = runDockerT (defaultClientOpts, defaultHttpHandler) $ do

25+ runDockerT (defaultClientOpts, h) $ do

24 let pb = PortBinding 80 TCP [HostPort "0.0.0.0" 8000]

26 let pb = PortBinding 80 TCP [HostPort "0.0.0.0" 8000]

25 let myCreateOpts = addPortBinding pb $ defaultCreateOpts "nginx:latest"

27 let myCreateOpts = addPortBinding pb $ defaultCreateOpts "nginx:latest"

26 cid <- createContainer myCreateOpts

28 cid <- createContainer myCreateOpts

@@ -42,7 +44,9 @@ Let's stop the container now:

43@

45@

44stopNginxContainer :: ContainerID -> IO ()

46stopNginxContainer :: ContainerID -> IO ()

47+stopNginxContainer cid = do

48+ h <- defaultHttpHandler

45−stopNginxContainer cid = runDockerT (defaultClientOpts, defaultHttpHandler) $ do

49+ runDockerT (defaultClientOpts, h) $ do

46 r <- stopContainer DefaultTimeout cid

50 r <- stopContainer DefaultTimeout cid

47 case r of

51 case r of

48 Left err -> error "I failed to stop the container"

52 Left err -> error "I failed to stop the container"

@@ -57,7 +61,9 @@ persist on the host file system.

58@

62@

59runPostgresContainer :: IO ContainerID

63runPostgresContainer :: IO ContainerID

64+runPostgresContainer = do

65+ h <- defaultHttpHandler

60−runPostgresContainer = runDockerT (defaultClientOpts, defaultHttpHandler) $ do

66+ runDockerT (defaultClientOpts, h) $ do

61 let pb = PortBinding 5432 TCP [HostPort "0.0.0.0" 5432]

67 let pb = PortBinding 5432 TCP [HostPort "0.0.0.0" 5432]

62 let myCreateOpts = addBinds [Bind "\/tmp" "\/tmp" Nothing] $ addPortBinding pb $ defaultCreateOpts "postgres:9.5"

68 let myCreateOpts = addBinds [Bind "\/tmp" "\/tmp" Nothing] $ addPortBinding pb $ defaultCreateOpts "postgres:9.5"

63 cid <- createContainer myCreateOpts

69 cid <- createContainer myCreateOpts

@@ -70,7 +76,8 @@ runPostgresContainer = runDockerT (defaultClientOpts, defaultHttpHandler) $ do

71= Get Docker API Version

77= Get Docker API Version

79+>>> h <- defaultHttpHandler

73−>>> runDockerT (defaultClientOpts, defaultHttpHandler) $ getDockerVersion

80+>>> runDockerT (defaultClientOpts, h) $ getDockerVersion

74Right (DockerVersion {version = "1.12.0", apiVersion = "1.24", gitCommit = "8eab29e", goVersion = "go1.6.3", os = "linux", arch = "amd64", kernelVersion = "4.6.0-1-amd64", buildTime = "2016-07-28T21:46:40.664812891+00:00"})

81Right (DockerVersion {version = "1.12.0", apiVersion = "1.24", gitCommit = "8eab29e", goVersion = "go1.6.3", os = "linux", arch = "amd64", kernelVersion = "4.6.0-1-amd64", buildTime = "2016-07-28T21:46:40.664812891+00:00"})

76= Setup SSL Authentication

83= Setup SSL Authentication

src/Docker/Client/Api.hs+66−14

@@ -18,12 +18,17 @@ module Docker.Client.Api (

18 , getContainerLogsStream

19 -- * Images

20 , listImages

21+ , deleteImage

21 , buildImageFromDockerfile

22 , buildImageFromDockerfile

23+ , pullImage

24+ -- * Network

25+ , createNetwork

26+ , removeNetwork

22 -- * Other

27 -- * Other

23 , getDockerVersion

28 , getDockerVersion

24 ) where

29 ) where

26−import Control.Monad.Catch (MonadMask(..))

31+import Control.Monad.Catch (MonadMask (..))

27import Control.Monad.IO.Class

32import Control.Monad.IO.Class

28import Control.Monad.Reader (ask, lift)

33import Control.Monad.Reader (ask, lift)

29import Data.Aeson (FromJSON, eitherDecode')

34import Data.Aeson (FromJSON, eitherDecode')

@@ -31,17 +36,18 @@ import qualified Data.ByteString as BS

31import qualified Data.ByteString.Lazy as BSL

36import qualified Data.ByteString.Lazy as BSL

32import Data.Conduit (Sink)

37import Data.Conduit (Sink)

33import qualified Data.Conduit.Binary as Conduit

38import qualified Data.Conduit.Binary as Conduit

39+import qualified Data.Text as T

34import qualified Data.Text as Text

40import qualified Data.Text as Text

35−import Network.HTTP.Client (responseStatus)

41+import Network.HTTP.Client (responseStatus)

36−import Network.HTTP.Types (StdMethod (..))

42+import Network.HTTP.Types (StdMethod (..))

37−import System.Exit (ExitCode(..))

43+import System.Exit (ExitCode (..))

39import Docker.Client.Http

45import Docker.Client.Http

40import Docker.Client.Types

46import Docker.Client.Types

41import Docker.Client.Utils

47import Docker.Client.Utils

43requestUnit :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())

49requestUnit :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())

44−requestUnit verb endpoint = const (Right ()) <$> requestHelper verb endpoint

50+requestUnit verb endpoint = fmap (const ()) <$> requestHelper verb endpoint

46requestHelper :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError BSL.ByteString)

52requestHelper :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError BSL.ByteString)

47requestHelper verb endpoint = requestHelper' verb endpoint Conduit.sinkLbs

53requestHelper verb endpoint = requestHelper' verb endpoint Conduit.sinkLbs

@@ -54,8 +60,8 @@ requestHelper' verb endpoint sink = do

54 return $ Left $ DockerInvalidRequest endpoint

60 return $ Left $ DockerInvalidRequest endpoint

55 Just request -> do

61 Just request -> do

56 -- JP: Do we need runResourceT?

62 -- JP: Do we need runResourceT?

57− -- lift $ NHS.httpSink request $ \response ->

63+ -- lift $ NHS.httpSink request $ \response ->

58− lift $ httpHandler request $ \response ->

64+ lift $ httpHandler request $ \response ->

59 -- Check status code.

65 -- Check status code.

60 let status = responseStatus response in

66 let status = responseStatus response in

61 case statusCodeToError endpoint status of

67 case statusCodeToError endpoint status of

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

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

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

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

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

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

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

99+-- defaults.

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

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

102+

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

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

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

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

93-- for some sane defaults.

105-- for some sane defaults.

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

133unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid

145unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid

134

146

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

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

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

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

137-- defaults.

149-- defaults.

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

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

139deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid

151deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid

140

152

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

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

@@ -149,27 +161,67 @@ inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= pars

149-- See 'LogOpts' for options that you can pass and

161-- See 'LogOpts' for options that you can pass and

150-- 'defaultLogOpts' for sane defaults.

162-- 'defaultLogOpts' for sane defaults.

151--

163--

152−-- __NOTE__: Currently streaming logs is

153−-- not supported and this function will fetch the entire log that the

164+-- __NOTE__: his function will fetch the entire log that the

154-- container produced in the json-file on disk. Depending on the logging

165-- container produced in the json-file on disk. Depending on the logging

155-- setup of the process in your container this can be a significant amount

166-- setup of the process in your container this can be a significant amount

156-- which might block your application...so use with caution.

167-- which might block your application...so use with caution.

157--

168--

169+-- If you want to stream the logs from the container continuosly then use

170+-- 'getContainerLogsStream'

171+--

158−-- The recommended method is to use one of the other 'LogDriverType's available (like

172+-- __NOTE__: It's recommended to use one of the other 'LogDriverType's available (like

159-- syslog) for creating your containers.

173-- syslog) for creating your containers.

160getContainerLogs :: forall m. (MonadIO m, MonadMask m) => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString)

174getContainerLogs :: forall m. (MonadIO m, MonadMask m) => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString)

161getContainerLogs logopts cid = requestHelper GET (ContainerLogsEndpoint logopts False cid)

175getContainerLogs logopts cid = requestHelper GET (ContainerLogsEndpoint logopts False cid)

162

176

177+{-| Continuously gets the container's logs as a stream. Uses conduit.

178+

179+__Example__:

180+

181+@

182+>>> import Docker.Client

183+>>> import Data.Maybe

184+>>> import Conduit

185+>>> h <- defaultHttpHanlder

186+>>> let cid = fromJust $ toContainerID "fee86e1d522b"

187+>>> runDockerT (defaultClientOpts, h) $ getContainerLogsStream defaultLogOpts cid stdoutC

188+@

189+

190+-}

163getContainerLogsStream :: forall m b . (MonadIO m, MonadMask m) => LogOpts -> ContainerID -> Sink BS.ByteString m b -> DockerT m (Either DockerError b)

191getContainerLogsStream :: forall m b . (MonadIO m, MonadMask m) => LogOpts -> ContainerID -> Sink BS.ByteString m b -> DockerT m (Either DockerError b)

164−getContainerLogsStream logopts cid sink = requestHelper' GET (ContainerLogsEndpoint logopts True cid) sink

192+getContainerLogsStream logopts cid = requestHelper' GET (ContainerLogsEndpoint logopts True cid)

165-- JP: Should the second (follow) argument be True? XXX

193-- JP: Should the second (follow) argument be True? XXX

166

194

195+-- | Build an Image from a Dockerfile

196+--

167-- TODO: Add X-Registry-Config

197-- TODO: Add X-Registry-Config

198+--

168-- TODO: Add support for remote URLs to a Dockerfile

199-- TODO: Add support for remote URLs to a Dockerfile

200+--

169-- TODO: Clean up temp tar.gz file after the image is built

201-- TODO: Clean up temp tar.gz file after the image is built

170buildImageFromDockerfile :: forall m. (MonadIO m, MonadMask m) => BuildOpts -> FilePath -> DockerT m (Either DockerError ())

202buildImageFromDockerfile :: forall m. (MonadIO m, MonadMask m) => BuildOpts -> FilePath -> DockerT m (Either DockerError ())

171buildImageFromDockerfile opts base = do

203buildImageFromDockerfile opts base = do

172 ctx <- makeBuildContext $ BuildContextRootDir base

204 ctx <- makeBuildContext $ BuildContextRootDir base

173 case ctx of

205 case ctx of

174− Left e -> return $ Left e

206+ Left e -> return $ Left e

175 Right c -> requestUnit POST (BuildImageEndpoint opts c)

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+

src/Docker/Client/Http.hs+51−13

@@ -4,8 +4,11 @@

4module Docker.Client.Http where

6-- import Control.Monad.Base (MonadBase(..), liftBaseDefault)

7−import Control.Monad.Catch (MonadMask(..))

7+import Control.Monad.Catch (MonadMask (..))

8+#if MIN_VERSION_http_conduit(2,3,0)

9+import Control.Monad.IO.Unlift (MonadUnliftIO)

10+#endif

8−import Control.Monad.Reader (ReaderT(..), runReaderT)

11+import Control.Monad.Reader (ReaderT (..), runReaderT)

9import qualified Data.ByteString.Char8 as BSC

12import qualified Data.ByteString.Char8 as BSC

10import qualified Data.ByteString.Lazy as BL

13import qualified Data.ByteString.Lazy as BL

11import Data.Conduit (Sink)

14import Data.Conduit (Sink)

@@ -17,13 +20,13 @@ import Data.X509.CertificateStore (makeCertificateStore)

17import Data.X509.File (readKeyFile, readSignedObject)

20import Data.X509.File (readKeyFile, readSignedObject)

18import Network.HTTP.Client (defaultManagerSettings,

21import Network.HTTP.Client (defaultManagerSettings,

19 managerRawConnection, method,

22 managerRawConnection, method,

20− newManager, parseUrl,

23+ newManager, parseRequest,

21 requestBody, requestHeaders)

24 requestBody, requestHeaders)

22import qualified Network.HTTP.Client as HTTP

25import qualified Network.HTTP.Client as HTTP

23import Network.HTTP.Client.Internal (makeConnection)

26import Network.HTTP.Client.Internal (makeConnection)

27+import qualified Network.HTTP.Simple as NHS

24import Network.HTTP.Types (StdMethod, status101, status200,

28import Network.HTTP.Types (StdMethod, status101, status200,

25 status201, status204)

29 status201, status204)

26−import qualified Network.HTTP.Simple as NHS

27import Network.TLS (ClientHooks (..),

30import Network.TLS (ClientHooks (..),

28 ClientParams (..), Shared (..),

31 ClientParams (..), Shared (..),

29 Supported (..),

32 Supported (..),

@@ -45,7 +48,7 @@ import Docker.Client.Internal (getEndpoint,

45 getEndpointContentType,

48 getEndpointContentType,

46 getEndpointRequestBody)

49 getEndpointRequestBody)

47import Docker.Client.Types (DockerClientOpts, Endpoint (..),

50import Docker.Client.Types (DockerClientOpts, Endpoint (..),

48− baseUrl)

51+ apiVer, baseUrl)

50type Request = HTTP.Request

53type Request = HTTP.Request

51type Response = HTTP.Response BL.ByteString

54type Response = HTTP.Response BL.ByteString

@@ -93,8 +96,8 @@ runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)

93-- benefit from testing that on all of our Endpoints

96-- benefit from testing that on all of our Endpoints

94mkHttpRequest :: HttpVerb -> Endpoint -> DockerClientOpts -> Maybe Request

97mkHttpRequest :: HttpVerb -> Endpoint -> DockerClientOpts -> Maybe Request

95mkHttpRequest verb e opts = request

98mkHttpRequest verb e opts = request

96− where fullE = T.unpack (baseUrl opts) ++ T.unpack (getEndpoint e)

99+ where fullE = T.unpack (baseUrl opts) ++ T.unpack (getEndpoint (apiVer opts) e)

97− initialR = parseUrl fullE

100+ initialR = parseRequest fullE

98 request' = case initialR of

101 request' = case initialR of

99 Just ir ->

102 Just ir ->

100 return $ ir {method = (encodeUtf8 . T.pack $ show verb),

103 return $ ir {method = (encodeUtf8 . T.pack $ show verb),

@@ -104,18 +107,30 @@ mkHttpRequest verb e opts = request

104 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'

107 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'

105 -- Note: Do we need to set length header?

108 -- Note: Do we need to set length header?

106

109

110+defaultHttpHandler :: (

111+#if MIN_VERSION_http_conduit(2,3,0)

112+ MonadUnliftIO m,

113+#endif

107−defaultHttpHandler :: (MonadIO m, MonadMask m) => m (HttpHandler m)

114+ MonadIO m, MonadMask m) => m (HttpHandler m)

108defaultHttpHandler = do

115defaultHttpHandler = do

109 manager <- liftIO $ newManager defaultManagerSettings

116 manager <- liftIO $ newManager defaultManagerSettings

110 return $ httpHandler manager

117 return $ httpHandler manager

111

118

119+httpHandler :: (

120+#if MIN_VERSION_http_conduit(2,3,0)

121+ MonadUnliftIO m,

122+#endif

112−httpHandler :: (MonadIO m, MonadMask m) => HTTP.Manager -> HttpHandler m

123+ MonadIO m, MonadMask m) => HTTP.Manager -> HttpHandler m

113−httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..

124+httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..

114 let request = NHS.setRequestManager manager request'

125 let request = NHS.setRequestManager manager request'

115 try (NHS.httpSink request sink) >>= \res -> case res of

126 try (NHS.httpSink request sink) >>= \res -> case res of

116 Right res -> return res

127 Right res -> return res

128+#if MIN_VERSION_http_client(0,5,0)

129+ Left e@(HTTP.HttpExceptionRequest _ HTTP.ConnectionFailure{}) -> return $ Left $ DockerConnectionError e

130+#else

117 Left e@HTTP.FailedConnectionException{} -> return $ Left $ DockerConnectionError e

131 Left e@HTTP.FailedConnectionException{} -> return $ Left $ DockerConnectionError e

118 Left e@HTTP.FailedConnectionException2{} -> return $ Left $ DockerConnectionError e

132 Left e@HTTP.FailedConnectionException2{} -> return $ Left $ DockerConnectionError e

133+#endif

119 Left e -> return $ Left $ GenericDockerError (T.pack $ show e)

134 Left e -> return $ Left $ GenericDockerError (T.pack $ show e)

120

135

121-- | Connect to a unix domain socket (the default docker socket is

136-- | Connect to a unix domain socket (the default docker socket is

@@ -123,7 +138,11 @@ httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..

123--

138--

124-- Docker seems to ignore the hostname in requests sent over unix domain

139-- Docker seems to ignore the hostname in requests sent over unix domain

125-- sockets (and the port obviously doesn't matter either)

140-- sockets (and the port obviously doesn't matter either)

141+unixHttpHandler :: (

142+#if MIN_VERSION_http_conduit(2,3,0)

143+ MonadUnliftIO m,

144+#endif

126−unixHttpHandler :: (MonadIO m, MonadMask m) => FilePath -- ^ The socket to connect to

145+ MonadIO m, MonadMask m) => FilePath -- ^ The socket to connect to

127 -> m (HttpHandler m)

146 -> m (HttpHandler m)

128unixHttpHandler fp = do

147unixHttpHandler fp = do

129 let mSettings = defaultManagerSettings

148 let mSettings = defaultManagerSettings

@@ -137,7 +156,7 @@ unixHttpHandler fp = do

137 S.connect s (S.SockAddrUnix filePath)

156 S.connect s (S.SockAddrUnix filePath)

138 makeConnection (SBS.recv s 8096)

157 makeConnection (SBS.recv s 8096)

139 (SBS.sendAll s)

158 (SBS.sendAll s)

140− (S.sClose s)

159+ (S.close s)

141

160

142-- TODO:

161-- TODO:

143-- Move this to http-client-tls or network?

162-- Move this to http-client-tls or network?

@@ -249,4 +268,23 @@ statusCodeToError (BuildImageEndpoint _ _) st =

249 Nothing

268 Nothing

250 else

269 else

251 Just $ DockerInvalidStatusCode st

270 Just $ DockerInvalidStatusCode st

252−

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+39−25

@@ -5,12 +5,13 @@ import qualified Data.Aeson as JSON

5import Data.ByteString (ByteString)

6import qualified Data.ByteString.Char8 as BSC

7import qualified Data.Conduit.Binary as CB

8−import Data.Text as T

8+import qualified Data.Text as T

9import Data.Text.Encoding (decodeUtf8, encodeUtf8)

10import qualified Network.HTTP.Client as HTTP

11import Network.HTTP.Conduit (requestBodySourceChunked)

12import Network.HTTP.Types (Query, encodePath,

13 encodePathSegments)

14+import Prelude hiding (all)

15import Docker.Client.Types

16import Docker.Client.Types

@@ -24,44 +25,44 @@ encodeURLWithQuery ps q = decodeUtf8 $ toByteString $ encodePath ps q

24encodeQ :: String -> ByteString

25encodeQ :: String -> ByteString

25encodeQ = encodeUtf8 . T.pack

26encodeQ = encodeUtf8 . T.pack

27−getEndpoint :: Endpoint -> T.Text

28+getEndpoint :: ApiVersion -> Endpoint -> T.Text

28−getEndpoint VersionEndpoint = encodeURL ["version"]

29+getEndpoint v VersionEndpoint = encodeURL [v, "version"]

29−getEndpoint (ListContainersEndpoint _) = encodeURL ["containers", "json"] -- Make use of lsOpts here

30+getEndpoint v (ListContainersEndpoint (ListOpts all)) = encodeURLWithQuery [v, "containers", "json"] [("all", Just (encodeQ $ show all))]

30−getEndpoint (ListImagesEndpoint _) = encodeURL ["images", "json"] -- Make use of lsOpts here

31+getEndpoint v (ListImagesEndpoint _) = encodeURL [v, "images", "json"] -- Make use of lsOpts here

31−getEndpoint (CreateContainerEndpoint _ cn) = case cn of

32+getEndpoint v (CreateContainerEndpoint _ cn) = case cn of

32− Just cn -> encodeURLWithQuery ["containers", "create"] [("name", Just (encodeQ $ T.unpack cn))]

33+ Just cn -> encodeURLWithQuery [v, "containers", "create"] [("name", Just (encodeQ $ T.unpack cn))]

33− Nothing -> encodeURL ["containers", "create"]

34+ Nothing -> encodeURL [v, "containers", "create"]

34−getEndpoint (StartContainerEndpoint startOpts cid) = encodeURLWithQuery ["containers", fromContainerID cid, "start"] query

35+getEndpoint v (StartContainerEndpoint startOpts cid) = encodeURLWithQuery [v, "containers", fromContainerID cid, "start"] query

35 where query = case (detachKeys startOpts) of

36 where query = case (detachKeys startOpts) of

36 WithCtrl c -> [("detachKeys", Just (encodeQ $ ctrl ++ [c]))]

37 WithCtrl c -> [("detachKeys", Just (encodeQ $ ctrl ++ [c]))]

37 WithoutCtrl c -> [("detachKeys", Just (encodeQ [c]))]

38 WithoutCtrl c -> [("detachKeys", Just (encodeQ [c]))]

38 DefaultDetachKey -> []

39 DefaultDetachKey -> []

39 ctrl = ['c', 't', 'r', 'l', '-']

40 ctrl = ['c', 't', 'r', 'l', '-']

40−getEndpoint (StopContainerEndpoint t cid) = encodeURLWithQuery ["containers", fromContainerID cid, "stop"] query

41+getEndpoint v (StopContainerEndpoint t cid) = encodeURLWithQuery [v, "containers", fromContainerID cid, "stop"] query

41 where query = case t of

42 where query = case t of

42− Timeout x -> [("t", Just (encodeQ $ show x))]

43+ Timeout x -> [("t", Just (encodeQ $ show x))]

43 DefaultTimeout -> []

44 DefaultTimeout -> []

44−getEndpoint (WaitContainerEndpoint cid) = encodeURL ["containers", fromContainerID cid, "wait"]

45+getEndpoint v (WaitContainerEndpoint cid) = encodeURL [v, "containers", fromContainerID cid, "wait"]

45−getEndpoint (KillContainerEndpoint s cid) = encodeURLWithQuery ["containers", fromContainerID cid, "kill"] query

46+getEndpoint v (KillContainerEndpoint s cid) = encodeURLWithQuery [v, "containers", fromContainerID cid, "kill"] query

46 where query = case s of

47 where query = case s of

47 SIG x -> [("signal", Just (encodeQ $ show x))]

48 SIG x -> [("signal", Just (encodeQ $ show x))]

48− _ -> [("signal", Just (encodeQ $ show s))]

49+ _ -> [("signal", Just (encodeQ $ show s))]

49−getEndpoint (RestartContainerEndpoint t cid) = encodeURLWithQuery ["containers", fromContainerID cid, "restart"] query

50+getEndpoint v (RestartContainerEndpoint t cid) = encodeURLWithQuery [v, "containers", fromContainerID cid, "restart"] query

50 where query = case t of

51 where query = case t of

51− Timeout x -> [("t", Just (encodeQ $ show x))]

52+ Timeout x -> [("t", Just (encodeQ $ show x))]

52 DefaultTimeout -> []

53 DefaultTimeout -> []

53−getEndpoint (PauseContainerEndpoint cid) = encodeURL ["containers", fromContainerID cid, "pause"]

54+getEndpoint v (PauseContainerEndpoint cid) = encodeURL [v, "containers", fromContainerID cid, "pause"]

54−getEndpoint (UnpauseContainerEndpoint cid) = encodeURL ["containers", fromContainerID cid, "unpause"]

55+getEndpoint v (UnpauseContainerEndpoint cid) = encodeURL [v, "containers", fromContainerID cid, "unpause"]

55-- Make use of since/timestamps/tail logopts here instead of ignoreing them

56-- Make use of since/timestamps/tail logopts here instead of ignoreing them

56−getEndpoint (ContainerLogsEndpoint (LogOpts stdout stderr _ _ _) follow cid) =

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

57− encodeURLWithQuery ["containers", fromContainerID cid, "logs"] query

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

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

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

59−getEndpoint (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =

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

60− encodeURLWithQuery ["containers", fromContainerID cid] query

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

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

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

62−getEndpoint (InspectContainerEndpoint cid) =

63+getEndpoint v (InspectContainerEndpoint cid) =

63− encodeURLWithQuery ["containers", fromContainerID cid, "json"] []

64+ encodeURLWithQuery [v, "containers", fromContainerID cid, "json"] []

64−getEndpoint (BuildImageEndpoint o _) = encodeURLWithQuery ["build"] query

65+getEndpoint v (BuildImageEndpoint o _) = encodeURLWithQuery [v, "build"] query

65 where query = [("t", Just t), ("dockerfile", Just dockerfile), ("q", Just q), ("nocache", Just nocache), ("rm", Just rm), ("forcerm", Just forcerm), ("pull", Just pull)]

66 where query = [("t", Just t), ("dockerfile", Just dockerfile), ("q", Just q), ("nocache", Just nocache), ("rm", Just rm), ("forcerm", Just forcerm), ("pull", Just pull)]

66 t = encodeQ $ T.unpack $ buildImageName o

67 t = encodeQ $ T.unpack $ buildImageName o

67 dockerfile = encodeQ $ T.unpack $ buildDockerfileName o

68 dockerfile = encodeQ $ T.unpack $ buildDockerfileName o

@@ -70,6 +71,13 @@ getEndpoint (BuildImageEndpoint o _) = encodeURLWithQuery ["build"] query

70 rm = encodeQ $ show $ buildRemoveItermediate o

71 rm = encodeQ $ show $ buildRemoveItermediate o

71 forcerm = encodeQ $ show $ buildForceRemoveIntermediate o

72 forcerm = encodeQ $ show $ buildForceRemoveIntermediate o

72 pull = encodeQ $ show $ buildPullParent 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]

74getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

82getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

75getEndpointRequestBody VersionEndpoint = Nothing

83getEndpointRequestBody VersionEndpoint = Nothing

@@ -86,7 +94,13 @@ getEndpointRequestBody (UnpauseContainerEndpoint _) = Nothing

86getEndpointRequestBody (ContainerLogsEndpoint _ _ _) = Nothing

94getEndpointRequestBody (ContainerLogsEndpoint _ _ _) = Nothing

87getEndpointRequestBody (DeleteContainerEndpoint _ _) = Nothing

95getEndpointRequestBody (DeleteContainerEndpoint _ _) = Nothing

88getEndpointRequestBody (InspectContainerEndpoint _) = Nothing

96getEndpointRequestBody (InspectContainerEndpoint _) = Nothing

97+

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

98getEndpointRequestBody (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

91getEndpointContentType :: Endpoint -> BSC.ByteString

105getEndpointContentType :: Endpoint -> BSC.ByteString

92getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar"

106getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar"

src/Docker/Client/Types.hs+215−89

@@ -11,6 +11,9 @@ module Docker.Client.Types (

11 , ImageID

12 , fromImageID

13 , toImageID

14+ , NetworkID

15+ , fromNetworkID

16+ , toNetworkID

14 , Timeout(..)

17 , Timeout(..)

15 , StatusCode(..)

18 , StatusCode(..)

16 , Signal(..)

19 , Signal(..)

@@ -23,11 +26,12 @@ module Docker.Client.Types (

23 , ContainerPortInfo(..)

26 , ContainerPortInfo(..)

24 , Container(..)

27 , Container(..)

25 , ContainerState(..)

28 , ContainerState(..)

26− , Status(..)

29+ , State(..)

27 , Digest

30 , Digest

28 , Label(..)

31 , Label(..)

29 , Tag

32 , Tag

30 , Image(..)

33 , Image(..)

34+ , Entrypoint(..)

31 , dropImagePrefix

35 , dropImagePrefix

32 , CreateOpts(..)

36 , CreateOpts(..)

33 , BuildOpts(..)

37 , BuildOpts(..)

@@ -36,12 +40,16 @@ module Docker.Client.Types (

36 , DetachKeys(..)

40 , DetachKeys(..)

37 , StartOpts(..)

41 , StartOpts(..)

38 , defaultStartOpts

42 , defaultStartOpts

39− , DeleteOpts(..)

43+ , ContainerDeleteOpts(..)

40− , defaultDeleteOpts

44+ , defaultContainerDeleteOpts

45+ , ImageDeleteOpts(..)

46+ , defaultImageDeleteOpts

41 , Timestamp

47 , Timestamp

42 , TailLogOpt(..)

48 , TailLogOpt(..)

43 , LogOpts(..)

49 , LogOpts(..)

44 , defaultLogOpts

50 , defaultLogOpts

51+ , CreateNetworkOpts(..)

52+ , defaultCreateNetworkOpts

45 , VolumePermission(..)

53 , VolumePermission(..)

46 , Bind(..)

54 , Bind(..)

47 , Volume(..)

55 , Volume(..)

@@ -67,6 +75,8 @@ module Docker.Client.Types (

67 , UTSMode(..)

75 , UTSMode(..)

68 , HostConfig(..)

76 , HostConfig(..)

69 , defaultHostConfig

77 , defaultHostConfig

78+ , NetworkingConfig(..)

79+ , EndpointConfig(..)

70 , Ulimit(..)

80 , Ulimit(..)

71 , ContainerResources(..)

81 , ContainerResources(..)

72 , defaultContainerResources

82 , defaultContainerResources

@@ -102,6 +112,7 @@ import Data.Scientific (floatingOrInteger)

102import Data.Text (Text)

112import Data.Text (Text)

103import qualified Data.Text as T

113import qualified Data.Text as T

104import Data.Time.Clock (UTCTime)

114import Data.Time.Clock (UTCTime)

115+import qualified Data.Vector as V

105import GHC.Generics (Generic)

116import GHC.Generics (Generic)

106import Prelude hiding (all, tail)

117import Prelude hiding (all, tail)

107import Text.Read (readMaybe)

118import Text.Read (readMaybe)

@@ -121,9 +132,13 @@ data Endpoint =

121 | UnpauseContainerEndpoint ContainerID

132 | UnpauseContainerEndpoint ContainerID

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

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

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

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

124− | DeleteContainerEndpoint DeleteOpts ContainerID

135+ | DeleteContainerEndpoint ContainerDeleteOpts ContainerID

125 | InspectContainerEndpoint ContainerID

136 | InspectContainerEndpoint ContainerID

126 | BuildImageEndpoint BuildOpts FilePath

137 | BuildImageEndpoint BuildOpts FilePath

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

127 deriving (Eq, Show)

142 deriving (Eq, Show)

128

143

129-- | We should newtype this

144-- | We should newtype this

@@ -198,16 +213,16 @@ data Signal = SIGHUP

198

213

199instance FromJSON Signal where

214instance FromJSON Signal where

200 parseJSON (JSON.String "SIGTERM") = return SIGTERM

215 parseJSON (JSON.String "SIGTERM") = return SIGTERM

201− parseJSON (JSON.String "SIGHUP") = return SIGHUP -- Note: Guessing on the string values for these.

216+ parseJSON (JSON.String "SIGHUP") = return SIGHUP -- Note: Guessing on the string values for these.

202− parseJSON (JSON.String "SIGINT") = return SIGINT

217+ parseJSON (JSON.String "SIGINT") = return SIGINT

203 parseJSON (JSON.String "SIGQUIT") = return SIGQUIT

218 parseJSON (JSON.String "SIGQUIT") = return SIGQUIT

204 parseJSON (JSON.String "SIGSTOP") = return SIGSTOP

219 parseJSON (JSON.String "SIGSTOP") = return SIGSTOP

205 parseJSON (JSON.String "SIGUSR1") = return SIGUSR1

220 parseJSON (JSON.String "SIGUSR1") = return SIGUSR1

206− parseJSON _ = fail "Unknown Signal"

221+ parseJSON _ = fail "Unknown Signal"

207

222

208instance ToJSON Signal where

223instance ToJSON Signal where

209− toJSON SIGHUP = "SIGHUP"

224+ toJSON SIGHUP = "SIGHUP"

210− toJSON SIGINT = "SIGINT"

225+ toJSON SIGINT = "SIGINT"

211 toJSON SIGQUIT = "SIGQUIT"

226 toJSON SIGQUIT = "SIGQUIT"

212 toJSON SIGSTOP = "SIGSTOP"

227 toJSON SIGSTOP = "SIGSTOP"

213 toJSON SIGTERM = "SIGTERM"

228 toJSON SIGTERM = "SIGTERM"

@@ -235,7 +250,7 @@ data ContainerDetails = ContainerDetails {

235 , processLabel :: Text

250 , processLabel :: Text

236 , resolveConfPath :: FilePath

251 , resolveConfPath :: FilePath

237 , restartCount :: Int

252 , restartCount :: Int

238− , state :: ContainerState

253+ , containerDetailsState :: ContainerState

239 , mounts :: [Mount]

254 , mounts :: [Mount]

240 }

255 }

241 deriving (Eq, Show, Generic)

256 deriving (Eq, Show, Generic)

@@ -243,11 +258,11 @@ data ContainerDetails = ContainerDetails {

243-- | Data type used for parsing the mount information from a container

258-- | Data type used for parsing the mount information from a container

244-- list.

259-- list.

245data Mount = Mount {

260data Mount = Mount {

246− mountName :: Text

261+ mountName :: Maybe Text -- this is optional

247 , mountSource :: FilePath

262 , mountSource :: FilePath

248 , mountDestination :: FilePath

263 , mountDestination :: FilePath

249− , mountDriver :: Text

264+ , mountDriver :: Maybe Text

250− , mountMode :: Maybe VolumePermission -- apparently this can be null

265+ -- , mountMode :: Maybe VolumePermission -- apparently this can be null

251 , mountRW :: Bool

266 , mountRW :: Bool

252 , mountPropogation :: Text

267 , mountPropogation :: Text

253 }

268 }

@@ -255,14 +270,14 @@ data Mount = Mount {

255

270

256instance FromJSON Mount where

271instance FromJSON Mount where

257 parseJSON (JSON.Object o) = do

272 parseJSON (JSON.Object o) = do

258− name <- o .: "Name"

273+ name <- o .:? "Name"

259 src <- o .: "Source"

274 src <- o .: "Source"

260 dest <- o .: "Destination"

275 dest <- o .: "Destination"

261− driver <- o .: "Driver"

276+ driver <- o .:? "Driver"

262− mode <- o .: "Mode"

277+ -- mode <- o .: "Mode"

263 rw <- o .: "RW"

278 rw <- o .: "RW"

264 prop <- o .: "Propagation"

279 prop <- o .: "Propagation"

265− return $ Mount name src dest driver mode rw prop

280+ return $ Mount name src dest driver rw prop

266 parseJSON _ = fail "Mount is not an object"

281 parseJSON _ = fail "Mount is not an object"

267

282

268-- | Data type used for parsing the container state from a list of

283-- | Data type used for parsing the container state from a list of

@@ -278,7 +293,7 @@ data ContainerState = ContainerState {

278 , restarting :: Bool

293 , restarting :: Bool

279 , running :: Bool

294 , running :: Bool

280 , startedAt :: UTCTime

295 , startedAt :: UTCTime

281− , status :: Status

296+ , state :: State

282 }

297 }

283 deriving (Eq, Show, Generic)

298 deriving (Eq, Show, Generic)

284

299

@@ -508,7 +523,8 @@ data Container = Container

508 , containerImageId :: ImageID

523 , containerImageId :: ImageID

509 , containerCommand :: Text

524 , containerCommand :: Text

510 , containerCreatedAt :: Int

525 , containerCreatedAt :: Int

526+ , containerState :: State

511− , containerStatus :: Status

527+ , containerStatus :: Maybe Text

512 , containerPorts :: [ContainerPortInfo]

528 , containerPorts :: [ContainerPortInfo]

513 , containerLabels :: [Label]

529 , containerLabels :: [Label]

514 , containerNetworks :: [Network]

530 , containerNetworks :: [Network]

@@ -516,13 +532,14 @@ data Container = Container

516 } deriving (Show, Eq)

532 } deriving (Show, Eq)

517

533

518instance FromJSON Container where

534instance FromJSON Container where

519− parseJSON (JSON.Object v) =

535+ parseJSON o@(JSON.Object v) =

520− Container <$> (v .: "Id")

536+ Container <$> parseJSON o

521 <*> (v .: "Names")

537 <*> (v .: "Names")

522 <*> (v .: "Image")

538 <*> (v .: "Image")

523− <*> (v .: "ImageID")

539+ <*> (v .: "ImageID") -- Doesn't exist anymore

524− <*> (v .: "Command")

540+ <*> (v .: "Command") -- Doesn't exist anymore

525 <*> (v .: "Created")

541 <*> (v .: "Created")

542+ <*> (v .: "State")

526 <*> (v .: "Status")

543 <*> (v .: "Status")

527 <*> (v .: "Ports")

544 <*> (v .: "Ports")

528 <*> (v .: "Labels")

545 <*> (v .: "Labels")

@@ -532,21 +549,20 @@ instance FromJSON Container where

532 parseNetworks (JSON.Object v) =

549 parseNetworks (JSON.Object v) =

533 (v .: "Networks") >>= parseJSON

550 (v .: "Networks") >>= parseJSON

534 parseNetworks _ = fail "Container NetworkSettings: Not a JSON object."

551 parseNetworks _ = fail "Container NetworkSettings: Not a JSON object."

535−

536 parseJSON _ = fail "Container: Not a JSON object."

552 parseJSON _ = fail "Container: Not a JSON object."

537

553

538−-- | Represents the status of the container life cycle.

554+-- | Represents the state of the container life cycle.

540 deriving (Eq, Show, Generic)

556 deriving (Eq, Show, Generic)

541

557

542−instance FromJSON Status where

558+instance FromJSON State where

543− parseJSON (JSON.String "running") = return Running

559+ parseJSON (JSON.String "running") = return Running

544− parseJSON (JSON.String "created") = return Created -- Note: Guessing on the string values of these.

560+ parseJSON (JSON.String "created") = return Created -- Note: Guessing on the string values of these.

545 parseJSON (JSON.String "restarting") = return Restarting

561 parseJSON (JSON.String "restarting") = return Restarting

546− parseJSON (JSON.String "paused") = return Paused

562+ parseJSON (JSON.String "paused") = return Paused

547− parseJSON (JSON.String "exited") = return Exited

563+ parseJSON (JSON.String "exited") = return Exited

548− parseJSON (JSON.String "dead") = return Dead

564+ parseJSON (JSON.String "dead") = return Dead

549− parseJSON _ = fail "Unknown Status"

565+ parseJSON s = fail $ "Unknown Status: " ++ show s

550

566

551-- | Alias for representing a RepoDigest. We could newtype this and add

567-- | Alias for representing a RepoDigest. We could newtype this and add

552-- some validation.

568-- some validation.

@@ -607,20 +623,46 @@ instance FromJSON Image where

607 return $ DockerImage imageId imageCreated imageParentId imageRepoTags imageRepoDigests imageSize imageVirtualSize imageLabels

623 return $ DockerImage imageId imageCreated imageParentId imageRepoTags imageRepoDigests imageSize imageVirtualSize imageLabels

608 parseJSON _ = fail "Failed to parse DockerImage."

624 parseJSON _ = fail "Failed to parse DockerImage."

609

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+ ]

610

649

611-- | Options used for creating a Container.

650-- | Options used for creating a Container.

612data CreateOpts = CreateOpts {

651data CreateOpts = CreateOpts {

613− containerConfig :: ContainerConfig

652+ containerConfig :: ContainerConfig

614− , hostConfig :: HostConfig

653+ , hostConfig :: HostConfig

654+ , networkingConfig :: NetworkingConfig

615 } deriving (Eq, Show)

655 } deriving (Eq, Show)

616

656

617instance ToJSON CreateOpts where

657instance ToJSON CreateOpts where

618− toJSON (CreateOpts cc hc) = do

658+ toJSON (CreateOpts cc hc nc) = do

619 let ccJSON = toJSON cc

659 let ccJSON = toJSON cc

620 let hcJSON = toJSON hc

660 let hcJSON = toJSON hc

621 case ccJSON of

661 case ccJSON of

622 JSON.Object (o :: HM.HashMap T.Text JSON.Value) -> do

662 JSON.Object (o :: HM.HashMap T.Text JSON.Value) -> do

623− JSON.Object $ HM.insert "HostConfig" hcJSON o

663+ let o1 = HM.insert "HostConfig" hcJSON o

664+ let o2 = HM.insert "NetworkingConfig" (toJSON nc) o1

665+ JSON.Object o2

624 _ -> error "ContainerConfig is not an object." -- This should never happen.

666 _ -> error "ContainerConfig is not an object." -- This should never happen.

625

667

626-- | Container configuration used for creating a container with sensible

668-- | Container configuration used for creating a container with sensible

@@ -642,7 +684,7 @@ defaultContainerConfig imageName = ContainerConfig {

642 , cmd=[]

684 , cmd=[]

643 , volumes=[]

685 , volumes=[]

644 , workingDir=Nothing

686 , workingDir=Nothing

645− , entrypoint=Nothing

687+ , entrypoint=Entrypoint []

646 , networkDisabled=Nothing

688 , networkDisabled=Nothing

647 , macAddress=Nothing

689 , macAddress=Nothing

648 , labels=[]

690 , labels=[]

@@ -655,7 +697,7 @@ defaultHostConfig = HostConfig {

655 binds=[]

697 binds=[]

656 , containerIDFile=Nothing

698 , containerIDFile=Nothing

657 , logConfig=LogDriverConfig JsonFile []

699 , logConfig=LogDriverConfig JsonFile []

658− , networkMode=Bridge

700+ , networkMode=NetworkBridge

659 , portBindings=[]

701 , portBindings=[]

660 , restartPolicy=RestartOff

702 , restartPolicy=RestartOff

661 , volumeDriver=Nothing

703 , volumeDriver=Nothing

@@ -695,14 +737,18 @@ defaultContainerResources = ContainerResources {

695 , memory=Nothing

737 , memory=Nothing

696 , memoryReservation=Nothing

738 , memoryReservation=Nothing

697 , memorySwap=Nothing

739 , memorySwap=Nothing

698− , oomKillDisable=False

740+ , oomKillDisable=Just False

699 , ulimits=[]

741 , ulimits=[]

700 }

742 }

701

743

702-- | Default create options when creating a container. You only need to

744-- | Default create options when creating a container. You only need to

703-- specify an image name and the rest is all sensible defaults.

745-- specify an image name and the rest is all sensible defaults.

704defaultCreateOpts :: T.Text -> CreateOpts

746defaultCreateOpts :: T.Text -> CreateOpts

747+defaultCreateOpts imageName = CreateOpts

705−defaultCreateOpts imageName = CreateOpts { containerConfig = defaultContainerConfig imageName, hostConfig = defaultHostConfig }

748+ { containerConfig = defaultContainerConfig imageName

749+ , hostConfig = defaultHostConfig

750+ , networkingConfig = NetworkingConfig HM.empty

751+ }

706

752

707-- | Override the key sequence for detaching a container.

753-- | Override the key sequence for detaching a container.

708-- Format is a single character [a-Z] or ctrl-<value> where <value> is one of: a-z, @, ^, [, , or _.

754-- Format is a single character [a-Z] or ctrl-<value> where <value> is one of: a-z, @, ^, [, , or _.

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

716defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }

762defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }

717

763

718-- | Options for deleting a container.

764-- | Options for deleting a container.

719−data DeleteOpts = DeleteOpts {

765+data ContainerDeleteOpts = ContainerDeleteOpts {

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

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

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

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

722 } deriving (Eq, Show)

768 } deriving (Eq, Show)

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

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

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

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

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

748-- running.

794-- running.

749−defaultDeleteOpts :: DeleteOpts

795+defaultContainerDeleteOpts :: ContainerDeleteOpts

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

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

797+

798+-- | Image delete opts

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

800+

801+-- | Sane image deletion defaults

802+defaultImageDeleteOpts :: ImageDeleteOpts

803+defaultImageDeleteOpts = ImageDeleteOpts

751

804

752-- | Timestamp alias.

805-- | Timestamp alias.

753type Timestamp = Integer

806type Timestamp = Integer

@@ -775,18 +828,50 @@ defaultLogOpts = LogOpts { stdout = True

775 , tail = All

828 , tail = All

776 }

829 }

777

830

831+-- | Options for creating a network

832+data CreateNetworkOpts = CreateNetworkOpts

833+ { createNetworkName :: Text -- ^ The network's name

834+ , createNetworkCheckDuplicate :: Bool -- ^ Check for networks with duplicate names.

835+ , createNetworkDriver :: Text -- ^ Name of the network driver plugin to use.

836+ , createNetworkInternal :: Bool -- ^ Restrict external access to the network.

837+ , createNetworkEnableIPv6 :: Bool -- ^ Enable IPv6 on the network.

838+ } deriving (Eq, Show)

839+

840+-- | Sensible defalut for create network options

841+defaultCreateNetworkOpts :: Text -> CreateNetworkOpts

842+defaultCreateNetworkOpts name =

843+ CreateNetworkOpts

844+ { createNetworkName = name

845+ , createNetworkCheckDuplicate = False

846+ , createNetworkDriver = "bridge"

847+ , createNetworkInternal = True

848+ , createNetworkEnableIPv6 = False

849+ }

850+

851+instance ToJSON CreateNetworkOpts where

852+ toJSON opts =

853+ object

854+ [ "Name" .= createNetworkName opts

855+ , "CheckDuplicate" .= createNetworkCheckDuplicate opts

856+ , "Driver" .= createNetworkDriver opts

857+ , "Internal" .= createNetworkInternal opts

858+ , "EnableIPv6" .= createNetworkEnableIPv6 opts

859+ ]

860+

778-- TOOD: Add support for SELinux Volume labels (eg. "ro,z" or "ro/Z")

861-- TOOD: Add support for SELinux Volume labels (eg. "ro,z" or "ro/Z")

779-- | Set permissions on volumes that you mount in the container.

862-- | Set permissions on volumes that you mount in the container.

780data VolumePermission = ReadWrite | ReadOnly deriving (Eq, Show, Generic)

863data VolumePermission = ReadWrite | ReadOnly deriving (Eq, Show, Generic)

781

864

782instance ToJSON VolumePermission where

865instance ToJSON VolumePermission where

783 toJSON ReadWrite = "rw"

866 toJSON ReadWrite = "rw"

784− toJSON ReadOnly = "ro"

867+ toJSON ReadOnly = "ro"

785

868

786instance FromJSON VolumePermission where

869instance FromJSON VolumePermission where

787 parseJSON "rw" = return ReadWrite

870 parseJSON "rw" = return ReadWrite

788 parseJSON "ro" = return ReadOnly

871 parseJSON "ro" = return ReadOnly

872+ parseJSON "RW" = return ReadWrite

873+ parseJSON "RO" = return ReadOnly

789− parseJSON _ = fail "Failed to parse VolumePermission"

874+ parseJSON _ = fail "Failed to parse VolumePermission"

790

875

791-- | Used for marking a directory in the container as "exposed" hence

876-- | Used for marking a directory in the container as "exposed" hence

792-- taking it outside of the COW filesystem and making it mountable

877-- taking it outside of the COW filesystem and making it mountable

@@ -808,8 +893,8 @@ instance {-# OVERLAPPING #-} ToJSON [Volume] where

808

893

809instance {-# OVERLAPPING #-} FromJSON [Volume] where

894instance {-# OVERLAPPING #-} FromJSON [Volume] where

810 parseJSON (JSON.Object o) = return $ map (Volume . T.unpack) $ HM.keys o

895 parseJSON (JSON.Object o) = return $ map (Volume . T.unpack) $ HM.keys o

811− parseJSON (JSON.Null) = return []

896+ parseJSON (JSON.Null) = return []

812− parseJSON _ = fail "Volume is not an object"

897+ parseJSON _ = fail "Volume is not an object"

813

898

814

899

815data Bind = Bind { hostSrc :: Text

900data Bind = Bind { hostSrc :: Text

@@ -819,10 +904,10 @@ data Bind = Bind { hostSrc :: Text

819

904

820instance FromJSON Bind where

905instance FromJSON Bind where

821 parseJSON (JSON.String t) = case T.split (== ':') t of

906 parseJSON (JSON.String t) = case T.split (== ':') t of

822− [src, dest] -> return $ Bind src dest Nothing

907+ [src, dest] -> return $ Bind src dest Nothing

823 [src, dest, "rw"] -> return $ Bind src dest $ Just ReadWrite

908 [src, dest, "rw"] -> return $ Bind src dest $ Just ReadWrite

824 [src, dest, "ro"] -> return $ Bind src dest $ Just ReadOnly

909 [src, dest, "ro"] -> return $ Bind src dest $ Just ReadOnly

825− _ -> fail "Could not parse Bind"

910+ _ -> fail "Could not parse Bind"

826 parseJSON _ = fail "Bind is not a string"

911 parseJSON _ = fail "Bind is not a string"

827

912

828data Device = Device {

913data Device = Device {

@@ -845,15 +930,15 @@ data VolumeFrom = VolumeFrom ContainerName (Maybe VolumePermission) deriving (Eq

845

930

846instance FromJSON VolumeFrom where

931instance FromJSON VolumeFrom where

847 parseJSON (JSON.String t) = case T.split (== ':') t of

932 parseJSON (JSON.String t) = case T.split (== ':') t of

848− [vol] -> return $ VolumeFrom vol Nothing

933+ [vol] -> return $ VolumeFrom vol Nothing

849 [vol, "rw"] -> return $ VolumeFrom vol $ Just ReadWrite

934 [vol, "rw"] -> return $ VolumeFrom vol $ Just ReadWrite

850 [vol, "ro"] -> return $ VolumeFrom vol $ Just ReadOnly

935 [vol, "ro"] -> return $ VolumeFrom vol $ Just ReadOnly

851− _ -> fail "Could not parse VolumeFrom"

936+ _ -> fail "Could not parse VolumeFrom"

852 parseJSON _ = fail "VolumeFrom is not a string"

937 parseJSON _ = fail "VolumeFrom is not a string"

853

938

854instance ToJSON VolumeFrom where

939instance ToJSON VolumeFrom where

855 toJSON (VolumeFrom n p) = case p of

940 toJSON (VolumeFrom n p) = case p of

856− Nothing -> toJSON $ n <> ":" <> "rw"

941+ Nothing -> toJSON $ n <> ":" <> "rw"

857 Just per -> toJSON $ n <> ":" <> (T.pack $ show per)

942 Just per -> toJSON $ n <> ":" <> (T.pack $ show per)

858

943

859instance ToJSON Bind where

944instance ToJSON Bind where

@@ -865,40 +950,40 @@ data Link = Link Text (Maybe Text) deriving (Eq, Show)

865

950

866instance FromJSON Link where

951instance FromJSON Link where

867 parseJSON (JSON.String t) = case T.split (== ':') t of

952 parseJSON (JSON.String t) = case T.split (== ':') t of

868− [f] -> return $ Link f Nothing

953+ [f] -> return $ Link f Nothing

869 [f,s] -> return $ Link f $ Just s

954 [f,s] -> return $ Link f $ Just s

870− _ -> fail "Could not parse Link"

955+ _ -> fail "Could not parse Link"

871 parseJSON _ = fail "Link is not a string"

956 parseJSON _ = fail "Link is not a string"

872

957

873instance ToJSON Link where

958instance ToJSON Link where

874 toJSON (Link n1 n2) = toJSON $ case n2 of

959 toJSON (Link n1 n2) = toJSON $ case n2 of

875 Nothing -> T.concat[n1, ":", n1] -- use same name in container

960 Nothing -> T.concat[n1, ":", n1] -- use same name in container

876− Just n -> T.concat[n1, ":", n] -- used specified name in container

961+ Just n -> T.concat[n1, ":", n] -- used specified name in container

877

962

878-- { "Type": "<driver_name>", "Config": {"key1": "val1"} }

963-- { "Type": "<driver_name>", "Config": {"key1": "val1"} }

880

965

881instance FromJSON LogDriverType where

966instance FromJSON LogDriverType where

882 parseJSON (JSON.String "json-file") = return JsonFile

967 parseJSON (JSON.String "json-file") = return JsonFile

883− parseJSON (JSON.String "syslog") = return Syslog

968+ parseJSON (JSON.String "syslog") = return Syslog

884− parseJSON (JSON.String "journald") = return Journald

969+ parseJSON (JSON.String "journald") = return Journald

885− parseJSON (JSON.String "gelf") = return Gelf

970+ parseJSON (JSON.String "gelf") = return Gelf

886− parseJSON (JSON.String "fluentd") = return Fluentd

971+ parseJSON (JSON.String "fluentd") = return Fluentd

887− parseJSON (JSON.String "awslogs") = return AwsLogs

972+ parseJSON (JSON.String "awslogs") = return AwsLogs

888− parseJSON (JSON.String "splunk") = return Splunk

973+ parseJSON (JSON.String "splunk") = return Splunk

889− parseJSON (JSON.String "etwlogs") = return Etwlogs

974+ parseJSON (JSON.String "etwlogs") = return Etwlogs

890− parseJSON (JSON.String "none") = return LoggingDisabled

975+ parseJSON (JSON.String "none") = return LoggingDisabled

891− parseJSON _ = fail "Unknown LogDriverType"

976+ parseJSON _ = fail "Unknown LogDriverType"

892

977

893instance ToJSON LogDriverType where

978instance ToJSON LogDriverType where

894− toJSON JsonFile = JSON.String "json-file"

979+ toJSON JsonFile = JSON.String "json-file"

895− toJSON Syslog = JSON.String "syslog"

980+ toJSON Syslog = JSON.String "syslog"

896− toJSON Journald = JSON.String "journald"

981+ toJSON Journald = JSON.String "journald"

897− toJSON Gelf = JSON.String "gelf"

982+ toJSON Gelf = JSON.String "gelf"

898− toJSON Fluentd = JSON.String "fluentd"

983+ toJSON Fluentd = JSON.String "fluentd"

899− toJSON AwsLogs = JSON.String "awslogs"

984+ toJSON AwsLogs = JSON.String "awslogs"

900− toJSON Splunk = JSON.String "splunk"

985+ toJSON Splunk = JSON.String "splunk"

901− toJSON Etwlogs = JSON.String "etwlogs"

986+ toJSON Etwlogs = JSON.String "etwlogs"

902 toJSON LoggingDisabled = JSON.String "none"

987 toJSON LoggingDisabled = JSON.String "none"

903

988

904data LogDriverOption = LogDriverOption Name Value deriving (Eq, Show)

989data LogDriverOption = LogDriverOption Name Value deriving (Eq, Show)

@@ -932,19 +1017,41 @@ instance FromJSON LogDriverConfig where

932 parseJSON _ = fail "LogDriverConfig is not an object"

1017 parseJSON _ = fail "LogDriverConfig is not an object"

933

1018

934-- TODO: Add container:<name|id> mode

1019-- TODO: Add container:<name|id> mode

935−data NetworkMode = Bridge | Host | NetworkDisabled

1020+data NetworkMode = NetworkBridge | NetworkHost | NetworkDisabled | NetworkNamed Text

936 deriving (Eq, Show, Ord)

1021 deriving (Eq, Show, Ord)

937

1022

938instance FromJSON NetworkMode where

1023instance FromJSON NetworkMode where

939− parseJSON (JSON.String "bridge") = return Bridge

1024+ parseJSON (JSON.String "bridge") = return NetworkBridge

940− parseJSON (JSON.String "host") = return Host -- Note: Guessing on these.

1025+ parseJSON (JSON.String "host") = return NetworkHost -- Note: Guessing on these.

941− parseJSON (JSON.String "none") = return NetworkDisabled

1026+ parseJSON (JSON.String "none") = return NetworkDisabled

1027+ parseJSON (JSON.String n) = return $ NetworkNamed n

942− parseJSON _ = fail "Unknown NetworkMode"

1028+ parseJSON _ = fail "Unknown NetworkMode"

943

1029

944instance ToJSON NetworkMode where

1030instance ToJSON NetworkMode where

945− toJSON Bridge = JSON.String "bridge"

1031+ toJSON NetworkBridge = JSON.String "bridge"

946− toJSON Host = JSON.String "host"

1032+ toJSON NetworkHost = JSON.String "host"

947 toJSON NetworkDisabled = JSON.String "none"

1033 toJSON NetworkDisabled = JSON.String "none"

1034+ toJSON (NetworkNamed n) = JSON.String n

1035+

1036+newtype NetworkID = NetworkID Text

1037+ deriving (Eq, Show)

1038+

1039+-- | Used for extracting the id of the container from the newtype

1040+fromNetworkID :: NetworkID -> Text

1041+fromNetworkID (NetworkID t) = t

1042+

1043+-- | Used for parsing a Text value into a NetworkID.

1044+toNetworkID :: Text -> Maybe NetworkID

1045+toNetworkID t = Just $ NetworkID t

1046+

1047+instance FromJSON NetworkID where

1048+ parseJSON (JSON.Object o) = do

1049+ nid <- o .: "Id"

1050+ return $ NetworkID nid

1051+ parseJSON _ = fail "NetworkID is not an object."

1052+

1053+instance ToJSON NetworkID where

1054+ toJSON (NetworkID nid) = object ["Id" .= nid]

948

1055

949data PortType = TCP | UDP deriving (Eq, Generic, Read, Ord)

1056data PortType = TCP | UDP deriving (Eq, Generic, Read, Ord)

950

1057

@@ -960,7 +1067,7 @@ instance FromJSON PortType where

960 parseJSON val = case val of

1067 parseJSON val = case val of

961 "tcp" -> return TCP

1068 "tcp" -> return TCP

962 "udp" -> return UDP

1069 "udp" -> return UDP

963− _ -> fail "PortType: Invalid port type."

1070+ _ -> fail "PortType: Invalid port type."

964

1071

965-- newtype NetworkInterface = NetworkInterface Text deriving (Eq, Show)

1072-- newtype NetworkInterface = NetworkInterface Text deriving (Eq, Show)

966--

1073--

@@ -1090,7 +1197,7 @@ instance FromJSON RestartPolicy where

1090 "on-failure" -> do

1197 "on-failure" -> do

1091 retry <- o .: "MaximumRetryCount"

1198 retry <- o .: "MaximumRetryCount"

1092 return $ RestartOnFailure retry

1199 return $ RestartOnFailure retry

1093− "off" -> return RestartOff

1200+ "no" -> return RestartOff

1094 _ -> fail "Could not parse RestartPolicy"

1201 _ -> fail "Could not parse RestartPolicy"

1095 parseJSON _ = fail "RestartPolicy is not an object"

1202 parseJSON _ = fail "RestartPolicy is not an object"

1096

1203

@@ -1098,7 +1205,7 @@ instance ToJSON RestartPolicy where

1098 toJSON RestartAlways = object ["Name" .= JSON.String "always"]

1205 toJSON RestartAlways = object ["Name" .= JSON.String "always"]

1099 toJSON RestartUnlessStopped = object ["Name" .= JSON.String "unless-stopped"]

1206 toJSON RestartUnlessStopped = object ["Name" .= JSON.String "unless-stopped"]

1100 toJSON (RestartOnFailure c) = object ["Name" .= JSON.String "on-failure", "MaximumRetryCount" .= c]

1207 toJSON (RestartOnFailure c) = object ["Name" .= JSON.String "on-failure", "MaximumRetryCount" .= c]

1101− toJSON RestartOff = object ["Name" .= JSON.String "off"]

1208+ toJSON RestartOff = object ["Name" .= JSON.String "no"]

1102

1209

1103data Isolation = Default | Process | Hyperv deriving (Eq, Show)

1210data Isolation = Default | Process | Hyperv deriving (Eq, Show)

1104

1211

@@ -1276,7 +1383,7 @@ data MemoryConstraintSize = B | MB | GB deriving (Eq, Show)

1276data MemoryConstraint = MemoryConstraint Integer MemoryConstraintSize deriving (Eq, Show)

1383data MemoryConstraint = MemoryConstraint Integer MemoryConstraintSize deriving (Eq, Show)

1277

1384

1278instance ToJSON MemoryConstraint where

1385instance ToJSON MemoryConstraint where

1279− toJSON (MemoryConstraint x B) = toJSON x

1386+ toJSON (MemoryConstraint x B) = toJSON x

1280 toJSON (MemoryConstraint x MB) = toJSON $ x * 1024 * 1024

1387 toJSON (MemoryConstraint x MB) = toJSON $ x * 1024 * 1024

1281 toJSON (MemoryConstraint x GB) = toJSON $ x * 1024 * 1024 * 1024

1388 toJSON (MemoryConstraint x GB) = toJSON $ x * 1024 * 1024 * 1024

1282

1389

@@ -1307,7 +1414,7 @@ data ContainerResources = ContainerResources {

1307 , memoryReservation :: Maybe MemoryConstraint

1414 , memoryReservation :: Maybe MemoryConstraint

1308 , memorySwap :: Maybe MemoryConstraint

1415 , memorySwap :: Maybe MemoryConstraint

1309 -- , memorySwappiness :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.

1416 -- , memorySwappiness :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.

1310− , oomKillDisable :: Bool

1417+ , oomKillDisable :: Maybe Bool

1311 -- , pidsLimit :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.

1418 -- , pidsLimit :: Integer -- 1.24: Missing from inspecting container details... Going to omit for now.

1312 , ulimits :: [Ulimit]

1419 , ulimits :: [Ulimit]

1313 -- TODO: Missing from 1.24

1420 -- TODO: Missing from 1.24

@@ -1345,7 +1452,7 @@ instance FromJSON EnvVar where

1345 parseJSON _ = fail "EnvVar is not a string"

1452 parseJSON _ = fail "EnvVar is not a string"

1346

1453

1347instance ToJSON EnvVar where

1454instance ToJSON EnvVar where

1348− toJSON (EnvVar n v) = object [n .= v]

1455+ toJSON (EnvVar n v) = JSON.String $ n <> T.pack "=" <> v

1349

1456

1350-- | ExposedPort represents a port (and it's type)

1457-- | ExposedPort represents a port (and it's type)

1351-- that a container should expose to other containers or the host system.

1458-- that a container should expose to other containers or the host system.

@@ -1385,6 +1492,21 @@ instance {-# OVERLAPPING #-} ToJSON [ExposedPort] where

1385 where key (ExposedPort p t) = show p <> slash <> show t

1492 where key (ExposedPort p t) = show p <> slash <> show t

1386 slash = T.unpack "/"

1493 slash = T.unpack "/"

1387

1494

1495+data Entrypoint = Entrypoint [T.Text] deriving (Eq, Show, Generic)

1496+

1497+instance ToJSON Entrypoint where

1498+ toJSON (Entrypoint (e:es)) = toJSON (e:es)

1499+ toJSON (Entrypoint []) = JSON.Null

1500+

1501+instance FromJSON Entrypoint where

1502+ parseJSON (JSON.String e) = return $ Entrypoint [e]

1503+ parseJSON (JSON.Array ar) = do

1504+ arr <- mapM parseJSON (V.toList ar)

1505+ return $ Entrypoint arr

1506+ parseJSON JSON.Null = return $ Entrypoint []

1507+ parseJSON _ = fail "Failed to parse Entrypoint"

1508+

1509+

1388data ContainerConfig = ContainerConfig {

1510data ContainerConfig = ContainerConfig {

1389 hostname :: Maybe Text

1511 hostname :: Maybe Text

1390 , domainname :: Maybe Text

1512 , domainname :: Maybe Text

@@ -1403,7 +1525,7 @@ data ContainerConfig = ContainerConfig {

1403 , image :: Text

1525 , image :: Text

1404 , volumes :: [Volume]

1526 , volumes :: [Volume]

1405 , workingDir :: Maybe FilePath

1527 , workingDir :: Maybe FilePath

1406− , entrypoint :: Maybe Text -- Can be null?

1528+ , entrypoint :: Entrypoint

1407 , networkDisabled :: Maybe Bool -- Note: Should we expand the JSON instance and take away the Maybe? Null is False?

1529 , networkDisabled :: Maybe Bool -- Note: Should we expand the JSON instance and take away the Maybe? Null is False?

1408 , macAddress :: Maybe Text

1530 , macAddress :: Maybe Text

1409 -- , onBuild :: Maybe Text -- For 1.24, only see this in the inspect response.

1531 -- , onBuild :: Maybe Text -- For 1.24, only see this in the inspect response.

@@ -1411,6 +1533,7 @@ data ContainerConfig = ContainerConfig {

1411 , stopSignal :: Signal

1533 , stopSignal :: Signal

1412 } deriving (Eq, Show, Generic)

1534 } deriving (Eq, Show, Generic)

1413

1535

1536+

1414instance ToJSON ContainerConfig where

1537instance ToJSON ContainerConfig where

1415 toJSON = genericToJSON defaultOptions {

1538 toJSON = genericToJSON defaultOptions {

1416 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}

1539 fieldLabelModifier = (\(x:xs) -> toUpper x : xs)}

@@ -1432,7 +1555,7 @@ instance FromJSON ContainerConfig where

1432 image <- o .: "Image"

1555 image <- o .: "Image"

1433 volumes <- o .: "Volumes"

1556 volumes <- o .: "Volumes"

1434 workingDir <- o .:? "WorkingDir"

1557 workingDir <- o .:? "WorkingDir"

1435− entrypoint <- o .:? "Entrypoint"

1558+ entrypoint <- o .: "Entrypoint"

1436 networkDisabled <- o .:? "networkDisabled"

1559 networkDisabled <- o .:? "networkDisabled"

1437 macAddress <- o .:? "MacAddress"

1560 macAddress <- o .:? "MacAddress"

1438 labels <- o .:? "Labels" .!= []

1561 labels <- o .:? "Labels" .!= []

@@ -1441,7 +1564,11 @@ instance FromJSON ContainerConfig where

1441 macAddress labels stopSignal

1564 macAddress labels stopSignal

1442 parseJSON _ = fail "NetworkSettings is not an object."

1565 parseJSON _ = fail "NetworkSettings is not an object."

1443

1566

1567+#if MIN_VERSION_base(4,13,0)

1568+parseIntegerText :: (MonadFail m) => Text -> m Integer

1569+#else

1444parseIntegerText :: (Monad m) => Text -> m Integer

1570parseIntegerText :: (Monad m) => Text -> m Integer

1571+#endif

1445parseIntegerText t = case readMaybe $ T.unpack t of

1572parseIntegerText t = case readMaybe $ T.unpack t of

1446 Nothing ->

1573 Nothing ->

1447 fail "Could not parse Integer"

1574 fail "Could not parse Integer"

@@ -1463,4 +1590,3 @@ toJsonKeyVal vs getKey getVal = JSON.Object $ foldl f HM.empty vs

1463-- | Helper function that return an empty dictionary "{}"

1590-- | Helper function that return an empty dictionary "{}"

1464emptyJsonObject :: JSON.Value

1591emptyJsonObject :: JSON.Value

1465emptyJsonObject = JSON.Object HM.empty

1592emptyJsonObject = JSON.Object HM.empty

1466−

stack-7.10.yaml+5−5

@@ -1,20 +1,20 @@

1# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md

3# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)

4−resolver: lts-5.18

4+resolver: lts-6.30

6# Local packages, usually specified by relative directory name

7packages:

8- '.'

10−# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)

11−extra-deps: [directory-1.2.7.0]

12−

13# Override default flag values for local packages and extra-deps

10# Override default flag values for local packages and extra-deps

14flags: {}

11flags: {}

16# Extra package databases containing global packages

13# Extra package databases containing global packages

17−extra-package-dbs: []

14+extra-deps:

15+- directory-1.2.7.0

16+- unliftio-core-0.1.1.0

17+- process-1.6.5.1

19# Control whether we use the GHC we find on the path

20# system-ghc: true

stack-8.0.2.yamlnew file+4

@@ -0,0 +1,4 @@

1+resolver: lts-9.4

2+packages:

3+- '.'

4+extra-deps: []

stack-8.0.yaml+2−1

@@ -1,4 +1,5 @@

1resolver: lts-7.12

2packages:

3- '.'

4−extra-deps: []

4+extra-deps:

5+- unliftio-core-0.1.1.0

stack-8.6.4.yamlnew file+4

@@ -0,0 +1,4 @@

1+resolver: lts-13.19

2+packages:

3+- '.'

4+extra-deps: []

stack-8.8.2.yamlnew file+5

@@ -0,0 +1,5 @@

1+resolver: lts-15.0

2+packages:

3+- '.'

4+extra-deps: []

stack.yaml+1−1

@@ -1 +1 @@

1−stack-7.10.yaml

1+stack-8.6.4.yaml

tests/Dockerfile+1−1

@@ -1,4 +1,4 @@

1FROM debian:jessie

3−CMD ["/bin/bash", "-c", "echo 123"]

3+CMD ["/bin/bash", "-c", "echo $TEST"]

tests/tests.hs+231−80

@@ -2,6 +2,8 @@

3module Main where

5+import Data.Either (rights)

6+import Prelude hiding (all)

5import qualified Test.QuickCheck.Monadic as QCM

7import qualified Test.QuickCheck.Monadic as QCM

6import Test.Tasty

8import Test.Tasty

7import Test.Tasty.HUnit

9import Test.Tasty.HUnit

@@ -9,135 +11,284 @@ import Test.Tasty.QuickCheck (testProperty)

10import Control.Concurrent (threadDelay)

12import Control.Concurrent (threadDelay)

11import Control.Lens ((^.), (^?))

13import Control.Lens ((^.), (^?))

14+import Control.Monad (forM_)

12import Control.Monad.IO.Class

15import Control.Monad.IO.Class

13import Control.Monad.Trans.Class (lift)

16import Control.Monad.Trans.Class (lift)

14import qualified Data.Aeson as JSON

17import qualified Data.Aeson as JSON

15−import Data.Aeson.Lens (key, _Object, _String, _Value)

18+import Data.Aeson ((.=))

19+import Data.Aeson.Lens (key, _Array, _Null, _Object,

20+ _String, _Value)

16import qualified Data.ByteString as B

21import qualified Data.ByteString as B

17import qualified Data.ByteString.Char8 as C

22import qualified Data.ByteString.Char8 as C

18import qualified Data.ByteString.Lazy as BL

23import qualified Data.ByteString.Lazy as BL

19import qualified Data.HashMap.Strict as HM

24import qualified Data.HashMap.Strict as HM

20import Data.Int (Int)

25import Data.Int (Int)

21import qualified Data.Map as M

26import qualified Data.Map as M

22−import Data.Maybe (fromJust, isJust)

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

23import Data.Monoid

28import Data.Monoid

24import Data.Text (Text, unpack)

29import Data.Text (Text, unpack)

30+import qualified Data.Vector as V

25import Network.Connection (TLSSettings (..))

31import Network.Connection (TLSSettings (..))

26import Network.HTTP.Client (newManager)

32import Network.HTTP.Client (newManager)

27import Network.HTTP.Client.TLS

33import Network.HTTP.Client.TLS

28import Network.HTTP.Types.Status

34import Network.HTTP.Types.Status

35+import System.Directory (getCurrentDirectory)

36+import System.Environment (lookupEnv)

29import System.Process (system)

37import System.Process (system)

31import Docker.Client

39import Docker.Client

33-- opts = defaultClientOpts

41-- opts = defaultClientOpts

34−

35−testImageName = "docker-hs-test"

42+testImageName = "docker-hs/test"

43+imageToDeleteFullName = "hello-world:latest"

37toStrict1 = B.concat . BL.toChunks

45toStrict1 = B.concat . BL.toChunks

39−runDocker f = do

47+runDocker f

40− -- let opts = defaultClientOpts {baseUrl = "https://127.0.0.1:2376/"}

48+ -- let opts = defaultClientOpts {baseUrl = "https://127.0.0.1:2376/"}

41− -- params' <- clientParamsWithClientAuthentication "127.0.0.1" 2376 "~/.docker/test-client-key.pem" "~/.docker/test-client-cert.pem" >>= fromRight

49+ -- params' <- clientParamsWithClientAuthentication "127.0.0.1" 2376 "~/.docker/test-client-key.pem" "~/.docker/test-client-cert.pem" >>= fromRight

42− -- params <- clientParamsSetCA params' "~/.docker/test-ca.pem"

50+ -- params <- clientParamsSetCA params' "~/.docker/test-ca.pem"

43− -- let settings = mkManagerSettings (TLSSettings params) Nothing

51+ -- let settings = mkManagerSettings (TLSSettings params) Nothing

44− -- mgr <- newManager settings

52+ -- mgr <- newManager settings

53+ = do

45− h <- defaultHttpHandler

54+ h <- defaultHttpHandler

46− runDockerT (defaultClientOpts, h) f

55+ runDockerT (defaultClientOpts, h) f

48testDockerVersion :: IO ()

57testDockerVersion :: IO ()

49−testDockerVersion = runDocker $ do

58+testDockerVersion =

59+ runDocker $

50− v <- getDockerVersion

60+ do v <- getDockerVersion

51− lift $ assert $ isRight v

61+ lift $ assert $ isRight v

62+

63+testStopNonexisting :: IO ()

64+testStopNonexisting = runDocker $ do

65+ res <- stopContainer DefaultTimeout $ fromJust $ toContainerID "thisshouldnotexist"

66+ lift $ assert $ isLeft res

53testFindImage :: IO ()

68testFindImage :: IO ()

54−testFindImage = runDocker $ do

69+testFindImage =

70+ runDocker $

71+ do images <- listImages defaultListOpts >>= fromRight

72+ let xs = filter (elem imageFullName . imageRepoTags) images

73+ lift $ assert $ length xs == 1

74+ where

75+ imageFullName = testImageName <> ":latest"

76+

77+testDeleteImage :: IO ()

78+testDeleteImage = runDocker $ do

79+ img <- fmap fromJust findTestImage

80+ result <- deleteImage defaultImageDeleteOpts (imageId img)

81+ lift $ assert $ isRight result

82+ maybeTestImageAfter <- findTestImage

83+ lift $ assert $ isNothing maybeTestImageAfter

84+ where

85+ findTestImage =

86+ do

55 images <- listImages defaultListOpts >>= fromRight

87 images <- listImages defaultListOpts >>= fromRight

88+ return $ listToMaybe

56− let xs = filter ((== [imageFullName]) . imageRepoTags) images

89+ $ filter (elem imageToDeleteFullName . imageRepoTags) images

57− lift $ assert $ length xs == 1

90+

58− where imageFullName = testImageName <> ":latest"

91+testListContainers :: IO ()

92+testListContainers =

93+ runDocker $

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

95+ c <- fromRight containerId

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

97+ deleteContainer (ContainerDeleteOpts True True) c

98+ lift $ assert $ isRight res

99+

100+testBuildFromDockerfile :: IO ()

101+testBuildFromDockerfile = do

102+ cur <- getCurrentDirectory

103+ let ctxDir = cur ++ "/tests"

104+ runDocker $ do

105+ r <- buildImageFromDockerfile (defaultBuildOpts "docker-hs/dockerfile-test") ctxDir

106+ lift $ assert $ isRight r

107+

108

60testRunAndReadLog :: IO ()

109testRunAndReadLog :: IO ()

110+testRunAndReadLog = testRunAndReadLogHelper $ NetworkingConfig HM.empty

111+

112+testRunAndReadLogWithNetworking :: IO ()

113+testRunAndReadLogWithNetworking = testRunAndReadLogHelper $ NetworkingConfig $ HM.fromList [("test-network", EndpointConfig ["cellar-door"])]

114+

115+testRunAndReadLogHelper :: NetworkingConfig -> IO ()

116+testRunAndReadLogHelper networkingConfig =

61−testRunAndReadLog = runDocker $ do

117+ runDocker $

62− containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing

118+ do let containerConfig = (defaultContainerConfig (testImageName <> ":latest")) {env = [EnvVar "TEST" "123"]}

119+ createdNetworks <- rights <$> mapM createNetworkWithName networkNames

120+ containerId <- createContainer (CreateOpts containerConfig defaultHostConfig networkingConfig) Nothing

63− c <- fromRight containerId

121+ c <- fromRight containerId

64− status1 <- startContainer defaultStartOpts c

122+ status1 <- startContainer defaultStartOpts c

65− _ <- inspectContainer c >>= fromRight

123+ _ <- inspectContainer c >>= fromRight

66− lift $ threadDelay 300000 -- give 300ms for the application to finish

124+ lift $ threadDelay 300000 -- give 300ms for the application to finish

67− lift $ assert $ isRightUnit status1

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

68− status2 <- killContainer SIGTERM c

69− logs <- getContainerLogs defaultLogOpts c >>= fromRight

126+ logs <- getContainerLogs defaultLogOpts c >>= fromRight

70− lift $ assert $ isRightUnit status2

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

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

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

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

73− lift $ assert $ isRightUnit status3

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

74−

130+ mapM_ removeNetwork createdNetworks

75− where

131+ where

76− isRightUnit (Right ()) = True

132+ isRightUnit (Right ()) = True

77− isRightUnit _ = False

133+ isRightUnit _ = False

134+ networkNames = HM.keys $ endpointsConfig networkingConfig

135+ createNetworkWithName name = createNetwork $

136+ (defaultCreateNetworkOpts name) { createNetworkCheckDuplicate = True }

137+

138+testCreateRemoveNetwork :: IO ()

139+testCreateRemoveNetwork = do

140+ runDocker $ do

141+ createStatus <- createNetwork $ defaultCreateNetworkOpts "test-network"

142+ lift $ assertBool ("creating a network, unexpected status: " ++ show createStatus) $ isRight createStatus

143+ nid <- fromRight createStatus

144+ removeStatus <- removeNetwork nid

145+ lift $ assertBool ("removing a network, unexpected status: " ++ show removeStatus) $ isRight removeStatus

146

79testLogDriverOptionsJson :: TestTree

147testLogDriverOptionsJson :: TestTree

80−testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [ test1, test2, test3 ]

148+testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [test1, test2, test3]

81− where

149+ where

82− test1 = testCase "Driver option 1" $ assert $ JSON.toJSON sample ^. key key1 . _String == val1

150+ test1 = testCase "Driver option 1" $ assert $ JSON.toJSON sample ^. key key1 . _String == val1

83− test2 = testCase "Driver option 2" $ assert $ JSON.toJSON sample ^. key key2 . _String == val2

151+ test2 = testCase "Driver option 2" $ assert $ JSON.toJSON sample ^. key key2 . _String == val2

152+ test3 =

84− test3 = testCase "Test override" $ assert $ JSON.toJSON sample2 ^. key key1 . _String == "override"

153+ testCase "Test override" $ assert $ JSON.toJSON sample2 ^. key key1 . _String == "override"

85− sample = [LogDriverOption key1 val1, LogDriverOption key2 val2]

154+ sample = [LogDriverOption key1 val1, LogDriverOption key2 val2]

86− sample2 = [LogDriverOption key1 val1, LogDriverOption key1 "override"]

155+ sample2 = [LogDriverOption key1 val1, LogDriverOption key1 "override"]

87− key1 = "some-key"

156+ key1 = "some-key"

88− val1 = "some-val"

157+ val1 = "some-val"

89− key2 = "some-key2"

158+ key2 = "some-key2"

90− val2 = "some-key2"

159+ val2 = "some-key2"

160

92testExposedPortsJson :: TestTree

161testExposedPortsJson :: TestTree

93−testExposedPortsJson = testGroup "Testing ExposedPorts JSON" [ testTCP, testUDP ]

162+testExposedPortsJson = testGroup "Testing ExposedPorts JSON" [testTCP, testUDP]

94− where

163+ where

95− testTCP = testCase "tcp port" $ assert $ JSON.toJSON sampleEP ^. key "80/tcp" . _Object == HM.empty

164+ testTCP = testCase "tcp port" $ assert $ JSON.toJSON sampleEP ^. key "80/tcp" . _Object == HM.empty

165+ testUDP =

96− testUDP = testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty

166+ testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty

97− sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP]

167+ sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP]

168

99testLabelsJson :: TestTree

169testLabelsJson :: TestTree

100−testLabelsJson = testGroup "Testing Labels JSON" [ testLS1, testLS2, testOverride ]

170+testLabelsJson = testGroup "Testing Labels JSON" [testLS1, testLS2, testOverride]

101− where

171+ where

102− testLS1 = testCase "test label key1" $ assert $ JSON.toJSON sampleLS ^. key key1 . _String == val1

172+ testLS1 = testCase "test label key1" $ assert $ JSON.toJSON sampleLS ^. key key1 . _String == val1

103− testLS2 = testCase "test label key2" $ assert $ JSON.toJSON sampleLS ^. key key2 . _String == val2

173+ testLS2 = testCase "test label key2" $ assert $ JSON.toJSON sampleLS ^. key key2 . _String == val2

174+ testOverride =

104− testOverride = testCase "test label override" $ assert $ JSON.toJSON [Label key1 val1, Label key1 "override"] ^. key key1 . _String == "override"

175+ testCase "test label override" $ assert $ JSON.toJSON [Label key1 val1, Label key1 "override"] ^.

176+ key key1 .

177+ _String ==

178+ "override"

105− sampleLS = [Label key1 val1, Label key2 val2]

179+ sampleLS = [Label key1 val1, Label key2 val2]

106− key1 = "com.example.some-label"

180+ key1 = "com.example.some-label"

107− val1 = "some-value"

181+ val1 = "some-value"

108− key2 = "something"

182+ key2 = "something"

109− val2 = "value"

183+ val2 = "value"

110

184

111testVolumesJson :: TestTree

185testVolumesJson :: TestTree

112−testVolumesJson = testGroup "Testing Volumes JSON" [ testSample1, testSample2 ]

186+testVolumesJson = testGroup "Testing Volumes JSON" [testSample1, testSample2]

113− where

187+ where

188+ testSample1 =

114− testSample1 = testCase "Test exposing volume: /tmp" $ assert $ JSON.toJSON sampleVolumes ^. key "/tmp" . _Object == HM.empty

189+ testCase "Test exposing volume: /tmp" $ assert $ JSON.toJSON sampleVolumes ^. key "/tmp" . _Object ==

190+ HM.empty

191+ testSample2 =

115− testSample2 = testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON sampleVolumes ^. key "/opt" . _Object == HM.empty

192+ testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON sampleVolumes ^. key "/opt" . _Object ==

193+ HM.empty

116− sampleVolumes = [Volume "/tmp", Volume "/opt"]

194+ sampleVolumes = [Volume "/tmp", Volume "/opt"]

195+

196+testEntrypointJson :: TestTree

197+testEntrypointJson = testGroup "Testing ContainerConfig JSON" [testSample1, testSample2, testSample3, testSample4, testSample5]

198+ where

199+ testSample1 =

200+ testCase "Test toJSON with empty entrypoint (null)" $ assert $ JSON.toJSON (Entrypoint []) ^. _Null == ()

201+ testSample2 =

202+ testCase "Test toJSON with entrypoint as Array" $ assert $

203+ JSON.toJSON (Entrypoint sampleEntrypointArr) ==

204+ JSON.toJSON sampleEntrypointArr

205+ testSample3 =

206+ testCase "Test decoding entrypoint as string" $ assert $ (JSON.decode "\"cmd\"") ==

207+ Just (Entrypoint ["cmd"])

208+ testSample4 =

209+ testCase "Test decoding as null" $ assert $ (JSON.decode "null" :: Maybe Entrypoint) ==

210+ Just (Entrypoint [])

211+ testSample5 =

212+ testCase "Test decoding as array" $ assert $ (JSON.decode (JSON.encode sampleEntrypointArr) :: Maybe Entrypoint) ==

213+ Just (Entrypoint sampleEntrypointArr)

214+ sampleEntrypointArr = ["cmd", "--some-flag", "--some-flag2"]

215+

216+testEnvVarJson :: TestTree

217+testEnvVarJson = testGroup "Testing EnvVar JSON" [testSampleEncode, testSampleDecode]

218+ where

219+ testSampleEncode =

220+ testCase "Test toJSON" $ assert $ JSON.toJSON (EnvVar "cellar" "door") == JSON.String "cellar=door"

221+ testSampleDecode =

222+ testCase "Test fromJSON" $ assert $ (JSON.decode "\"cellar=door\"" :: Maybe EnvVar) ==

223+ Just (EnvVar "cellar" "door")

224+

225+testNetworkingConfigJson :: TestTree

226+testNetworkingConfigJson = testGroup "Testing NetworkingConfig JSON" [testSampleEncode]

227+ where

228+ testSampleEncode =

229+ let networkingConfig = NetworkingConfig $ HM.fromList [("custom-network", EndpointConfig ["cellar", "door"])]

230+ in testCase "Test toJSON" $ assert $ JSON.toJSON networkingConfig ==

231+ JSON.object

232+ [ "EndpointsConfig" .= JSON.object

233+ [ "custom-network" .= JSON.object

234+ [ "Aliases" .= (["cellar", "door"] :: [Text])

235+ ]

236+ ]

237+ ]

117

238

118integrationTests :: TestTree

239integrationTests :: TestTree

119−integrationTests = testGroup "Integration Tests" [

240+integrationTests =

241+ testGroup

242+ "Integration Tests"

120− testCase "Get docker version" testDockerVersion,

243+ [ testCase "Get docker version" testDockerVersion

244+ , testCase "Build image from Dockerfile" testBuildFromDockerfile

121− testCase "Find image by name" testFindImage,

245+ , testCase "Find image by name" testFindImage

246+ , testCase "Delete image" testDeleteImage

247+ , testCase "List containers" testListContainers

122− testCase "Run a dummy container and read its log" testRunAndReadLog]

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

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

250+ , testCase "Try to stop a container that doesn't exist" testStopNonexisting

251+ , testCase "Create and remove a network" testCreateRemoveNetwork

252+ ]

123

253

124jsonTests :: TestTree

254jsonTests :: TestTree

125−jsonTests = testGroup "JSON Tests" [testExposedPortsJson, testVolumesJson, testLabelsJson, testLogDriverOptionsJson]

255+jsonTests =

256+ testGroup

257+ "JSON Tests"

258+ [ testExposedPortsJson

259+ , testVolumesJson

260+ , testLabelsJson

261+ , testLogDriverOptionsJson

262+ , testEntrypointJson

263+ , testEnvVarJson

264+ , testNetworkingConfigJson

265+ ]

126

266

127setup :: IO ()

267setup :: IO ()

268+setup =

269+ mapM_ system

270+ [ "docker pull " ++ unpack imageToDeleteFullName

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

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

272+ ]

273+

274+isLeft = not . isRight

129

275

130−isRight (Left _) = False

276+isRight (Left _) = False

131isRight (Right _) = True

277isRight (Right _) = True

132

278

279+fromRight

133−fromRight :: (MonadIO m, Show l) => Either l r -> m r

280+ :: (MonadIO m, Show l)

281+ => Either l r -> m r

134fromRight (Left l) = do

282fromRight (Left l) = do

135− liftIO $ assertFailure $ "Left: " ++ show l

283+ liftIO $ assertFailure $ "Left: " ++ show l

136− undefined

284+ undefined

137fromRight (Right r) = return r

285fromRight (Right r) = return r

138

286

139main :: IO ()

287main :: IO ()

140main = do

288main = do

289+ stackage <- lookupEnv "RUN_INTEGRATION_TESTS"

290+ case stackage of

291+ Nothing -> defaultMain $ testGroup "Tests" [jsonTests]

292+ Just _ -> do

141− setup

293+ setup

142− defaultMain $ testGroup "Tests" [jsonTests, integrationTests]

294+ defaultMain $ testGroup "Tests" [jsonTests, integrationTests]

143−