master..ac2efb2 · docker-hs

git.iko.soy/docker-hs

on ac2efb2 help sign in

.gitignore−1

since splitsnapshots

unifiedsplit

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

4*~

5.stack-work/

6dist-newstyle

7−/cabal.project.local

.travis.yml+3−31

@@ -1,12 +1,6 @@

1sudo: required

2dist: trusty

4−# Only build master and release tags

5−branches:

6− only:

7− - master

8− - /^v\d+\.\d+(\.\d+)?(-\S*)?$/

9−

10# Choose a lightweight base image; we provide our own build tools.

4# Choose a lightweight base image; we provide our own build tools.

11language:

5language:

12 c

6 c

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

22 - docker

16 - docker

24env:

18env:

25− global:

19+ - GHCVER=7.10 STACK_ARGS=""

26− - RUN_INTEGRATION_TESTS=1

20+ - GHCVER=8.0 STACK_ARGS=""

27− - STACK_ARGS=""

28−

29− matrix:

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

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

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

33−

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

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

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

37−

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

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

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

41−

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

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

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

45−

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

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

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

50addons:

22addons:

51 apt:

23 apt:

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

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

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

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

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

59 - sudo apt-get update

31 - sudo apt-get update

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

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

62install:

34install:

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

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

CHANGELOG.md−71

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

1# CHANGELOG

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

4−

5−- Support for ghc 8.8.2.

6−- Bump dependency version.

7−- Use MonadFail for later versions.

8−

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

10−

11−- Support ghc 8.6.4.

12−- Bump containers version.

13−

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

15−

16−- Rename DeleteOpts to ContainerDeleteOpts.

17−- Implement image deletion.

18−- Bump aeson version.

19−- Implement network aliases.

20−- Implement creating/deleting networks.

21−

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

23−

24−- Bump aeson version.

25−

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

27−

28−- Support http-conduit-2.3.0.

29−- Bump http-types versions.

30−

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

32−

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

34−

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

36−

37−- Added (some) contribution and general docs

38−- Fix case when stopping non-existent container

39−- Added more integration tests

40−- Fixed error while parsing list container endpoint output

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

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

43−- Fixed EnvVar JSON encoding

44−- Fixed NetworkMode parsing

45−- Allow http-types 0.11

46−

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

48−

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

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

51−

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

53−

54−- Relaxed aeson, tls and time upper bounds

55−

56−

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

58−

59−- Support LTS 9.4

60−

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

62−

63−- fixes omKillDisable parsing from json

64−- adds Entrypoint data type and tests edge cases

65−- more tests

66−- small comsmetic changes

67−

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

69−

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

71−- Added support for streaming log output

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

73−

74## 0.3.0.1 (2016-09-07)

3## 0.3.0.1 (2016-09-07)

76- Small cosmetic changes and marking OVERLAPPING instance

5- Small cosmetic changes and marking OVERLAPPING instance

CONTRIBUTING.md+2−12

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

1−# Contributing

1+# TODO

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

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

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+2−21

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

1−.PHONY: build repl test release help

1+.PHONY: build repl test release

2−

3−.DEFAULT_GOAL = help

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

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

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

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

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

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

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

9ARCH=$(shell uname -m)

7ARCH=$(shell uname -m)

11−## Run build

12build:

9build:

13 @stack build

10 @stack build

15−## Run repl

16repl:

12repl:

17 @stack repl

13 @stack repl

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

20test:

15test:

21− @RUN_INTEGRATION_TESTS=1 stack test

16+ @stack test

23−## Cut new release

24release:

18release:

25 @stack build --haddock

19 @stack build --haddock

26 @stack sdist

20 @stack sdist

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

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

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

22 @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+10−37

@@ -1,48 +1,21 @@

1# An API client for docker written in Haskell

3−| Master |

3+| Master | Dev |

4−| -------|

4+| -------| ---- |

5−| [![master](https://travis-ci.org/denibertovic/docker-hs.svg?branch=master)](https://travis-ci.org/denibertovic/docker-hs) |

5+| [![master](https://travis-ci.org/denibertovic/docker-hs.svg?branch=master)](https://travis-ci.org/denibertovic/docker-hs) | [![dev](https://travis-ci.org/denibertovic/docker-hs.svg?branch=dev)](https://travis-ci.org/denibertovic/docker-hs) |

8## Current state

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

10+**API is still no stable.**

11−

11+We're looking to stabilize the API after the next release (0.4.0.0)

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

22## Contributing

13## Contributing

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

15+If you wish to contribute please see any issue tagged with "help wanted".

25−

16+Make sure to submit your PR's against the `dev` branch.

26−### Project Setup

27−

28−For working on the library, you need the Haskell Tool Stack installed (see [the

29−Haskell Tool Stack

30−website](https://docs.haskellstack.org/en/stable/install_and_upgrade/)). You

31−also need `make` to use the `Makefile` included in the project. Run `make help`

32−to see the available commands (for building, running the tests and releasing).

33−

34−### Tests

35−

36−Tests are located in the `tests` directory and can be run with `make test`. This

37−only runs the unit tests.

38−

39−To run integration tests, you need Docker installed and listening on Port `2375`

40−of `localhost` (docker only listens to a Unix socket by default, see the [Docker

41−documentation](https://docs.docker.com/engine/reference/commandline/dockerd/#daemon-socket-option)

42−for details). Set the environment variable `RUN_INTEGRATION_TESTS`, i.e.

43−`RUN_INTEGRATION_TESTS=1 make test`.

45−## IRC

18+Please consider filling an Issue first and discuss design decisions and implementation details before

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

20+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+12−42

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

1name: docker

2−version: 0.6.0.3

2+version: 0.3.0.1

3synopsis: An API client for docker written in Haskell

4description: See API documentation below.

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

@@ -14,57 +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−

22library

17library

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

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

24 hs-source-dirs: src

19 hs-source-dirs: src

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

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

26 -- other-modules: Docker.Internal

21 -- other-modules: Docker.Internal

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

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

28− , aeson >= 0.9.0 && < 2.0.0

23+ , aeson >= 0.9.0 && < 1.1.0

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

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

30 , bytestring >= 0.10.0 && < 0.11.0

25 , bytestring >= 0.10.0 && < 0.11.0

31− , containers >= 0.5.0 && < 0.7.0

26+ , containers >= 0.5.0 && < 0.6.0

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

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

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

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

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

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

35− , vector

36− , conduit

37− , conduit-combinators

38− , conduit-extra

39− , exceptions

40− , monad-control

41− , resourcet

42− , transformers

43− , transformers-base

44− , tar

45− , zlib

46− , uuid

47− , temporary

48− , directory >= 1.2.5.0

49− , filemanip

50− , filepath

51 , mtl >= 2.0.0 && < 3.0.0

30 , mtl >= 2.0.0 && < 3.0.0

52 , network >= 2.6.0

31 , network >= 2.6.0

53 , text >= 1.0.0 && < 2.0.0

32 , text >= 1.0.0 && < 2.0.0

54− , time >= 1.5.0 && < 2.0.0

33+ , time >= 1.5.0 && < 1.7.0

55 , scientific >= 0.3.0 && < 0.4.0

34 , scientific >= 0.3.0 && < 0.4.0

56− , tls >= 1.3.7 && < 1.6.0

35+ , tls >= 1.3.7 && < 1.4.0

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

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

58− , x509 >= 1.6.0 && < 1.8.0

37+ , x509 >= 1.6.0 && < 1.7.0

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

38+ , x509-store >= 1.6.0 && < 1.7.0

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

39+ , x509-system >= 1.6.0 && < 1.7.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

68 default-language: Haskell2010

40 default-language: Haskell2010

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

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

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

73 , bytestring

45 , bytestring

74 , connection

46 , connection

75 , docker

47 , docker

76− , directory

77 , aeson

48 , aeson

78 , containers

49 , containers

79 , unordered-containers

50 , unordered-containers

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

89 , transformers

60 , transformers

90 , QuickCheck

61 , QuickCheck

91 , process

62 , process

92− , vector

93 type: exitcode-stdio-1.0

63 type: exitcode-stdio-1.0

94 main-is: tests.hs

64 main-is: tests.hs

95 hs-source-dirs: tests

65 hs-source-dirs: tests

examples/Example.hs+43−52

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

1import Docker.Client

3runNginxContainer :: IO ContainerID

4−runNginxContainer = do

5− h <- defaultHttpHandler

6− runDockerT (defaultClientOpts, h) $

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

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

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

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

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

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

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

10− case cid of

8+ case cid of

11− Left err -> error $ show err

9+ Left err -> error $ show err

12− Right i -> do

10+ Right i -> do

13− _ <- startContainer defaultStartOpts i

11+ _ <- startContainer defaultStartOpts i

14− return i

12+ return i

16stopNginxContainer :: ContainerID -> IO ()

14stopNginxContainer :: ContainerID -> IO ()

17−stopNginxContainer cid = do

18− h <- defaultHttpHandler

19− runDockerT (defaultClientOpts, h) $

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

20− do r <- stopContainer DefaultTimeout cid

16+ r <- stopContainer DefaultTimeout cid

21− case r of

17+ case r of

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

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

23− Right _ -> return ()

19+ Right _ -> return ()

25runPostgresContainer :: IO ContainerID

21runPostgresContainer :: IO ContainerID

26−runPostgresContainer = do

27− h <- defaultHttpHandler

28− runDockerT (defaultClientOpts, h) $

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

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

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

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

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

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

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

32− cid <- createContainer myCreateOpts Nothing

26+ cid <- createContainer myCreateOpts Nothing

33− case cid of

27+ case cid of

34− Left err -> error $ show err

28+ Left err -> error $ show err

35− Right i -> do

29+ Right i -> do

36− _ <- startContainer defaultStartOpts i

30+ _ <- startContainer defaultStartOpts i

37− return i

31+ return i

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

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

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

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

41runPostgresWithDataContainer :: IO ContainerID

35runPostgresWithDataContainer :: IO ContainerID

42−runPostgresWithDataContainer = do

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

43− h <- defaultHttpHandler

44− runDockerT (defaultClientOpts, h) $

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

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

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

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

47− -- create a container filesystem for us.

39+ -- create a container filesystem for us.

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

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

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

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

50− _ <-

51− case cid of

42+ _ <- case cid of

52− Left err -> error $ show err

43+ Left err -> error $ show err

53− Right i -> startContainer defaultStartOpts i

44+ Right i -> startContainer defaultStartOpts i

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

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

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

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

56− let vf = VolumeFrom "myDataContainer" Nothing

47+ let vf = VolumeFrom "myDataContainer" Nothing

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

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

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

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

59− case ccid of

50+ case ccid of

60− Left err -> error $ show err

51+ Left err -> error $ show err

61− Right i -> do

52+ Right i -> do

62− _ <- startContainer defaultStartOpts i

53+ _ <- startContainer defaultStartOpts i

63− return i

54+ return i

src/Docker/Client.hs+5−12

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

4{-|

5Module : Docker.Client

6−Copyright : (c) Deni Bertovic, 2014

6+Copyright : (c) Deni Bertovic, 2016

7License : BSD3

8Maintainer : deni@denibertovic.com

9Stability : experimental

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

20import Docker.Client

22runNginxContainer :: IO ContainerID

23−runNginxContainer = do

24− h <- defaultHttpHandler

25− runDockerT (defaultClientOpts, h) $ do

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

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

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

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

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

28 cid <- createContainer myCreateOpts

26 cid <- createContainer myCreateOpts

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

45@

43@

46stopNginxContainer :: ContainerID -> IO ()

44stopNginxContainer :: ContainerID -> IO ()

47−stopNginxContainer cid = do

48− h <- defaultHttpHandler

49− runDockerT (defaultClientOpts, h) $ do

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

50 r <- stopContainer DefaultTimeout cid

46 r <- stopContainer DefaultTimeout cid

51 case r of

47 case r of

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

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

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

62@

58@

63runPostgresContainer :: IO ContainerID

59runPostgresContainer :: IO ContainerID

64−runPostgresContainer = do

65− h <- defaultHttpHandler

66− runDockerT (defaultClientOpts, h) $ do

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

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

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

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

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

69 cid <- createContainer myCreateOpts

63 cid <- createContainer myCreateOpts

@@ -76,8 +70,7 @@ runPostgresContainer = do

77= Get Docker API Version

71= Get Docker API Version

79−>>> h <- defaultHttpHandler

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

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

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

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"})

83= Setup SSL Authentication

76= Setup SSL Authentication

src/Docker/Client/Api.hs+50−121

@@ -15,113 +15,89 @@ module Docker.Client.Api (

15 , deleteContainer

16 , inspectContainer

17 , getContainerLogs

18− , getContainerLogsStream

19 -- * Images

18 -- * Images

20 , listImages

19 , listImages

21− , deleteImage

22− , buildImageFromDockerfile

23− , pullImage

24− -- * Network

25− , createNetwork

26− , removeNetwork

27 -- * Other

20 -- * Other

28 , getDockerVersion

21 , getDockerVersion

29 ) where

22 ) where

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

24+import Control.Monad.Except (ExceptT (..), runExceptT, throwError)

32−import Control.Monad.IO.Class

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

25+import Control.Monad.Reader (ask, lift)

34−import Data.Aeson (FromJSON, eitherDecode')

26+import Data.Aeson (FromJSON, eitherDecode')

35−import qualified Data.ByteString as BS

27+import qualified Data.ByteString.Lazy as BSL

36−import qualified Data.ByteString.Lazy as BSL

37−import Data.Conduit (Sink)

38−import qualified Data.Conduit.Binary as Conduit

39−import qualified Data.Text as T

28+import qualified Data.Text as Text

40−import qualified Data.Text as Text

41−import Network.HTTP.Client (responseStatus)

29+import Network.HTTP.Client (responseBody, responseStatus)

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

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

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

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

45import Docker.Client.Http

33import Docker.Client.Http

46import Docker.Client.Types

34import Docker.Client.Types

47−import Docker.Client.Utils

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

36+requestUnit :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError ())

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

37+requestUnit verb endpoint = const (Right ()) <$> requestHelper verb endpoint

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

39+requestHelper :: (Monad m) => HttpVerb -> Endpoint -> DockerT m (Either DockerError Response)

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

40+requestHelper verb endpoint = runExceptT $ do

54−

55−requestHelper' :: (MonadIO m, MonadMask m) => HttpVerb -> Endpoint -> Sink BS.ByteString m a -> DockerT m (Either DockerError a)

56−requestHelper' verb endpoint sink = do

57− (opts, HttpHandler httpHandler) <- ask

41+ (opts, httpHandler) <- lift ask

58 case mkHttpRequest verb endpoint opts of

42 case mkHttpRequest verb endpoint opts of

59 Nothing ->

43 Nothing ->

60− return $ Left $ DockerInvalidRequest endpoint

44+ throwError $ DockerInvalidRequest endpoint

61 Just request -> do

45 Just request -> do

62− -- JP: Do we need runResourceT?

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

64− lift $ httpHandler request $ \response ->

46+ response <- ExceptT $ lift $ httpHandler request

47+

65− -- Check status code.

48+ -- Check status code.

66− let status = responseStatus response in

49+ let status = responseStatus response

50+ maybe (return ()) throwError $

67− case statusCodeToError endpoint status of

51+ statusCodeToError endpoint status

68− Just err ->

52+

69− return $ Left err

53+ return response

70− Nothing ->

54+

71− fmap Right sink

72−

73−parseResponse :: (FromJSON a, Monad m) => Either DockerError BSL.ByteString -> DockerT m (Either DockerError a)

55+parseResponse :: (FromJSON a, Monad m) => Either DockerError Response -> DockerT m (Either DockerError a)

74parseResponse (Left err) =

56parseResponse (Left err) =

75 return $ Left err

57 return $ Left err

76parseResponse (Right response) =

58parseResponse (Right response) =

77 -- Parse request body.

59 -- Parse request body.

78− case eitherDecode' response of

60+ case eitherDecode' $ responseBody response of

79 Left err ->

61 Left err ->

80 return $ Left $ DockerClientDecodeError $ Text.pack err

62 return $ Left $ DockerClientDecodeError $ Text.pack err

81 Right r ->

63 Right r ->

82 return $ Right r

64 return $ Right r

84-- | Gets the version of the docker engine remote API.

66-- | Gets the version of the docker engine remote API.

85−getDockerVersion :: forall m. (MonadIO m, MonadMask m) => DockerT m (Either DockerError DockerVersion)

67+getDockerVersion :: forall m. Monad m => DockerT m (Either DockerError DockerVersion)

86getDockerVersion = requestHelper GET VersionEndpoint >>= parseResponse

68getDockerVersion = requestHelper GET VersionEndpoint >>= parseResponse

88-- | Lists all running docker containers. Pass in @'defaultListOpts' {all

70-- | Lists all running docker containers. Pass in @'defaultListOpts' {all

89-- = True}@ to get a list of stopped containers as well.

71-- = True}@ to get a list of stopped containers as well.

90−listContainers :: forall m. (MonadIO m, MonadMask m) => ListOpts -> DockerT m (Either DockerError [Container])

72+listContainers :: forall m. Monad m => ListOpts -> DockerT m (Either DockerError [Container])

91listContainers opts = requestHelper GET (ListContainersEndpoint opts) >>= parseResponse

73listContainers opts = requestHelper GET (ListContainersEndpoint opts) >>= parseResponse

93-- | Lists all docker images.

75-- | Lists all docker images.

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

76+listImages :: forall m. Monad m => ListOpts -> DockerT m (Either DockerError [Image])

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

77listImages 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−

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

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

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

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

105-- for some sane defaults.

81-- for some sane defaults.

106−createContainer :: forall m. (MonadIO m, MonadMask m) => CreateOpts -> Maybe ContainerName -> DockerT m (Either DockerError ContainerID)

82+createContainer :: forall m. Monad m => CreateOpts -> Maybe ContainerName -> DockerT m (Either DockerError ContainerID)

107createContainer opts cn = requestHelper POST (CreateContainerEndpoint opts cn) >>= parseResponse

83createContainer opts cn = requestHelper POST (CreateContainerEndpoint opts cn) >>= parseResponse

108

109-- | Start a container from a given 'ContainerID' that we get from

85-- | Start a container from a given 'ContainerID' that we get from

110-- 'createContainer'. See 'StartOpts' for a list of configuration options

86-- 'createContainer'. See 'StartOpts' for a list of configuration options

111-- for starting a container. Use 'defaultStartOpts' for sane defaults.

87-- for starting a container. Use 'defaultStartOpts' for sane defaults.

112−startContainer :: forall m. (MonadIO m, MonadMask m) => StartOpts -> ContainerID -> DockerT m (Either DockerError ())

88+startContainer :: forall m. Monad m => StartOpts -> ContainerID -> DockerT m (Either DockerError ())

113startContainer sopts cid = requestUnit POST $ StartContainerEndpoint sopts cid

89startContainer sopts cid = requestUnit POST $ StartContainerEndpoint sopts cid

114

115-- | Attempts to stop a container with the given 'ContainerID' gracefully

91-- | Attempts to stop a container with the given 'ContainerID' gracefully

116-- (SIGTERM).

92-- (SIGTERM).

117-- The docker daemon will wait for the given 'Timeout' and then send

93-- The docker daemon will wait for the given 'Timeout' and then send

118-- a SIGKILL killing the container.

94-- a SIGKILL killing the container.

119−stopContainer :: forall m. (MonadIO m, MonadMask m) => Timeout -> ContainerID -> DockerT m (Either DockerError ())

95+stopContainer :: forall m. Monad m => Timeout -> ContainerID -> DockerT m (Either DockerError ())

120stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid

96stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid

121

122-- | Blocks until a container with the given 'ContainerID' stops,

98-- | Blocks until a container with the given 'ContainerID' stops,

123-- then returns the exit code

99-- then returns the exit code

124−waitContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ExitCode)

100+waitContainer :: forall m. Monad m => ContainerID -> DockerT m (Either DockerError ExitCode)

125waitContainer cid = fmap (fmap statusCodeToExitCode) (requestHelper POST (WaitContainerEndpoint cid) >>= parseResponse)

101waitContainer cid = fmap (fmap statusCodeToExitCode) (requestHelper POST (WaitContainerEndpoint cid) >>= parseResponse)

126 where

102 where

127 statusCodeToExitCode (StatusCode 0) = ExitSuccess

103 statusCodeToExitCode (StatusCode 0) = ExitSuccess

@@ -129,29 +105,29 @@ waitContainer cid = fmap (fmap statusCodeToExitCode) (requestHelper POST (WaitCo

129

105

130-- | Sends a 'Signal' to the container with the given 'ContainerID'. Same

106-- | Sends a 'Signal' to the container with the given 'ContainerID'. Same

131-- as 'stopContainer' but you choose the signal directly.

107-- as 'stopContainer' but you choose the signal directly.

132−killContainer :: forall m. (MonadIO m, MonadMask m) => Signal -> ContainerID -> DockerT m (Either DockerError ())

108+killContainer :: forall m. Monad m => Signal -> ContainerID -> DockerT m (Either DockerError ())

133killContainer s cid = requestUnit POST $ KillContainerEndpoint s cid

109killContainer s cid = requestUnit POST $ KillContainerEndpoint s cid

134

110

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

111-- | Restarts a container with the given 'ContainerID'.

136−restartContainer :: forall m. (MonadIO m, MonadMask m) => Timeout -> ContainerID -> DockerT m (Either DockerError ())

112+restartContainer :: forall m. Monad m => Timeout -> ContainerID -> DockerT m (Either DockerError ())

137restartContainer t cid = requestUnit POST $ RestartContainerEndpoint t cid

113restartContainer t cid = requestUnit POST $ RestartContainerEndpoint t cid

138

114

139-- | Pauses a container with the given 'ContainerID'.

115-- | Pauses a container with the given 'ContainerID'.

140−pauseContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ())

116+pauseContainer :: forall m. Monad m => ContainerID -> DockerT m (Either DockerError ())

141pauseContainer cid = requestUnit POST $ PauseContainerEndpoint cid

117pauseContainer cid = requestUnit POST $ PauseContainerEndpoint cid

142

118

143-- | Unpauses a container with the given 'ContainerID'.

119-- | Unpauses a container with the given 'ContainerID'.

144−unpauseContainer :: forall m. (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ())

120+unpauseContainer :: forall m. Monad m => ContainerID -> DockerT m (Either DockerError ())

145unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid

121unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid

146

122

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

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

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

124+-- See "DeleteOpts" for options and use 'defaultDeleteOpts' for sane

149-- defaults.

125-- defaults.

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

126+deleteContainer :: forall m. Monad m => DeleteOpts -> ContainerID -> DockerT m (Either DockerError ())

151deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid

127deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid

152

128

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

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

154−inspectContainer :: forall m . (MonadIO m, MonadMask m) => ContainerID -> DockerT m (Either DockerError ContainerDetails)

130+inspectContainer :: forall m . Monad m => ContainerID -> DockerT m (Either DockerError ContainerDetails)

155inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= parseResponse

131inspectContainer cid = requestHelper GET (InspectContainerEndpoint cid) >>= parseResponse

156

132

157-- | Get's container's logs for a given 'ContainerID'.

133-- | Get's container's logs for a given 'ContainerID'.

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

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

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

162-- 'defaultLogOpts' for sane defaults.

138-- 'defaultLogOpts' for sane defaults.

163--

139--

140+-- __NOTE__: Currently streaming logs is

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

141+-- not supported and this function will fetch the entire log that the

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

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

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

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

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

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

168--

145--

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

170−-- 'getContainerLogsStream'

171−--

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

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

173-- syslog) for creating your containers.

147-- syslog) for creating your containers.

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

148+getContainerLogs :: forall m. Monad m => LogOpts -> ContainerID -> DockerT m (Either DockerError BSL.ByteString)

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

149+getContainerLogs logopts cid = fmap responseBody <$> requestHelper GET (ContainerLogsEndpoint logopts False cid)

176−

150+

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

151+-- TODO: Use http-conduit to output to a sink.

178−

179−__Example__:

180−

181−@

182−>>> import Docker.Client

183−>>> import Data.Maybe

184−>>> import Conduit

185−>>> h <- defaultHttpHanlder

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

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

188−@

189−

190−-}

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

152+-- getContainerLogsStream :: forall m. Monad m => Sink BSL.ByteString m b -> LogOpts -> ContainerID -> DockerT m (Either DockerError b)

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

153+-- getContainerLogsStream sink logopts cid = runResourceT $ do

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

154+-- response <- http request manager

194−

155+-- responseBody response C.$$+- sink

195−-- | Build an Image from a Dockerfile

196−--

197−-- TODO: Add X-Registry-Config

198−--

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

200−--

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

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

203−buildImageFromDockerfile opts base = do

204− ctx <- makeBuildContext $ BuildContextRootDir base

205− case ctx of

206− Left e -> return $ Left e

207− Right c -> requestUnit POST (BuildImageEndpoint opts c)

208−

209−-- | Pulls an image from Docker Hub (by default).

210−--

211−-- TODO: Add support for X-Registry-Auth and pulling from private docker

212−-- registries.

213−--

214−-- TODO: Implement importImage function that uses he same

215−-- CreateImageEndpoint but rather than pulling from docker hub it imports

216−-- the image from a tarball or a URL.

217−pullImage :: forall m b . (MonadIO m, MonadMask m) => T.Text -> Tag -> Sink BS.ByteString m b -> DockerT m (Either DockerError b)

218−pullImage name tag = requestHelper' POST (CreateImageEndpoint name tag Nothing)

219−

220−-- | Creates network

221−createNetwork :: forall m. (MonadIO m, MonadMask m) => CreateNetworkOpts -> DockerT m (Either DockerError NetworkID)

222−createNetwork opts = requestHelper POST (CreateNetworkEndpoint opts) >>= parseResponse

223−

224−-- | Removes a network

225−removeNetwork :: forall m. (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError ())

226−removeNetwork nid = requestUnit DELETE $ RemoveNetworkEndpoint nid

227

156

src/Docker/Client/Http.hs+29−81

@@ -3,28 +3,21 @@

4module Docker.Client.Http where

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

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

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

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

10−#endif

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

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

12import qualified Data.ByteString.Char8 as BSC

7import qualified Data.ByteString.Char8 as BSC

13import qualified Data.ByteString.Lazy as BL

8import qualified Data.ByteString.Lazy as BL

14−import Data.Conduit (Sink)

15import Data.Default.Class (def)

9import Data.Default.Class (def)

16import Data.Monoid ((<>))

10import Data.Monoid ((<>))

17import Data.Text.Encoding (encodeUtf8)

11import Data.Text.Encoding (encodeUtf8)

18import Data.X509 (CertificateChain (..))

12import Data.X509 (CertificateChain (..))

19import Data.X509.CertificateStore (makeCertificateStore)

13import Data.X509.CertificateStore (makeCertificateStore)

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

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

21−import Network.HTTP.Client (defaultManagerSettings,

15+import Network.HTTP.Client (defaultManagerSettings, httpLbs,

22 managerRawConnection, method,

16 managerRawConnection, method,

23− newManager, parseRequest,

17+ newManager, parseUrl,

24 requestBody, requestHeaders)

18 requestBody, requestHeaders)

25import qualified Network.HTTP.Client as HTTP

19import qualified Network.HTTP.Client as HTTP

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

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

27−import qualified Network.HTTP.Simple as NHS

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

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

29 status201, status204)

22 status201, status204)

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

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

@@ -34,7 +27,7 @@ import Network.TLS (ClientHooks (..),

34import Network.TLS.Extra (ciphersuite_strong)

27import Network.TLS.Extra (ciphersuite_strong)

35import System.X509 (getSystemCertificateStore)

28import System.X509 (getSystemCertificateStore)

37−import Control.Monad.Catch (try)

30+import Control.Exception (try)

38import Control.Monad.Except

31import Control.Monad.Except

39import Control.Monad.Reader.Class

32import Control.Monad.Reader.Class

40import Data.Text as T

33import Data.Text as T

@@ -45,22 +38,20 @@ import qualified Network.Socket.ByteString as SBS

47import Docker.Client.Internal (getEndpoint,

40import Docker.Client.Internal (getEndpoint,

48− getEndpointContentType,

49 getEndpointRequestBody)

41 getEndpointRequestBody)

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

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

51− apiVer, baseUrl)

43+ baseUrl)

53type Request = HTTP.Request

45type Request = HTTP.Request

54type Response = HTTP.Response BL.ByteString

46type Response = HTTP.Response BL.ByteString

55type HttpVerb = StdMethod

47type HttpVerb = StdMethod

56−newtype HttpHandler m = HttpHandler (forall a . Request -> (HTTP.Response () -> Sink BSC.ByteString m (Either DockerError a)) -> m (Either DockerError a))

48+type HttpHandler m = Request -> m (Either DockerError Response)

58−data DockerError = DockerConnectionError NHS.HttpException

50+data DockerError = DockerConnectionError

59 | DockerInvalidRequest Endpoint

51 | DockerInvalidRequest Endpoint

60− | DockerClientError Text

61 | DockerClientDecodeError Text -- ^ Could not parse the response from the Docker endpoint.

52 | DockerClientDecodeError Text -- ^ Could not parse the response from the Docker endpoint.

62 | DockerInvalidStatusCode HTTP.Status -- ^ Invalid exit code received from Docker endpoint.

53 | DockerInvalidStatusCode HTTP.Status -- ^ Invalid exit code received from Docker endpoint.

63− | GenericDockerError Text deriving (Show, Typeable)

54+ | GenericDockerError Text deriving (Eq, Show, Typeable)

65newtype DockerT m a = DockerT {

56newtype DockerT m a = DockerT {

66 unDockerT :: Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a

57 unDockerT :: Monad m => ReaderT (DockerClientOpts, HttpHandler m) m a

@@ -84,9 +75,6 @@ instance MonadTrans DockerT where

84instance MonadIO m => MonadIO (DockerT m) where

75instance MonadIO m => MonadIO (DockerT m) where

85 liftIO = lift . liftIO

76 liftIO = lift . liftIO

87−-- instance MonadBase IO m => MonadBase IO (DockerT m) where

88−-- liftBase = liftBaseDefault

89−

90runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a

78runDockerT :: Monad m => (DockerClientOpts, HttpHandler m) -> DockerT m a -> m a

91runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)

79runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)

@@ -96,41 +84,28 @@ runDockerT (opts, h) r = runReaderT (unDockerT r) (opts, h)

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

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

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

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

98mkHttpRequest verb e opts = request

86mkHttpRequest verb e opts = request

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

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

100− initialR = parseRequest fullE

88+ initialR = parseUrl fullE

101 request' = case initialR of

89 request' = case initialR of

102 Just ir ->

90 Just ir ->

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

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

104− requestHeaders = [("Content-Type", (getEndpointContentType e))]}

92+ requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}

105 Nothing -> Nothing

93 Nothing -> Nothing

106− request = (\r -> maybe r (\body -> r {requestBody = body, -- This will either be a HTTP.RequestBodyLBS or HTTP.RequestBodySourceChunked for the build endpoint

94+ request = (\r -> maybe r (\body -> r {requestBody = HTTP.RequestBodyLBS body,

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

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

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

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

109

110−defaultHttpHandler :: (

98+defaultHttpHandler :: MonadIO m => HttpHandler m

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

112− MonadUnliftIO m,

113−#endif

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

115−defaultHttpHandler = do

99+defaultHttpHandler request = do

116 manager <- liftIO $ newManager defaultManagerSettings

100 manager <- liftIO $ newManager defaultManagerSettings

117− return $ httpHandler manager

101+ httpHandler manager request

118−

102+

119−httpHandler :: (

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

121− MonadUnliftIO m,

122−#endif

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

103+httpHandler :: MonadIO m => HTTP.Manager -> HttpHandler m

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

104+httpHandler manager request = liftIO $ do

125− let request = NHS.setRequestManager manager request'

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

105+ try (httpLbs request manager) >>= \res -> case res of

127− Right res -> return res

106+ Right res -> return $ Right res

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

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

130−#else

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

107+ Left HTTP.FailedConnectionException{} -> return $ Left DockerConnectionError

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

108+ Left HTTP.FailedConnectionException2{} -> return $ Left DockerConnectionError

133−#endif

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

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

135

110

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

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

@@ -138,17 +113,13 @@ httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..

138--

113--

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

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

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

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

141−unixHttpHandler :: (

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

143− MonadUnliftIO m,

144−#endif

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

116+unixHttpHandler :: MonadIO m => FilePath -- ^ The socket to connect to

146− -> m (HttpHandler m)

117+ -> HttpHandler m

147−unixHttpHandler fp = do

118+unixHttpHandler fp request = do

148 let mSettings = defaultManagerSettings

119 let mSettings = defaultManagerSettings

149 { managerRawConnection = return $ openUnixSocket fp}

120 { managerRawConnection = return $ openUnixSocket fp}

150 manager <- liftIO $ newManager mSettings

121 manager <- liftIO $ newManager mSettings

151− return $ httpHandler manager

122+ httpHandler manager request

152

123

153 where

124 where

154 openUnixSocket filePath _ _ _ = do

125 openUnixSocket filePath _ _ _ = do

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

156 S.connect s (S.SockAddrUnix filePath)

127 S.connect s (S.SockAddrUnix filePath)

157 makeConnection (SBS.recv s 8096)

128 makeConnection (SBS.recv s 8096)

158 (SBS.sendAll s)

129 (SBS.sendAll s)

159− (S.close s)

130+ (S.sClose s)

160

131

161-- TODO:

132-- TODO:

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

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

@@ -263,28 +234,5 @@ statusCodeToError (InspectContainerEndpoint _) st =

263 Nothing

234 Nothing

264 else

235 else

265 Just $ DockerInvalidStatusCode st

236 Just $ DockerInvalidStatusCode st

266−statusCodeToError (BuildImageEndpoint _ _) st =

237+

267− if st == status200 then

238+

268− Nothing

269− else

270− Just $ DockerInvalidStatusCode st

271−statusCodeToError (CreateImageEndpoint _ _ _) st =

272− if st == status200 then

273− Nothing

274− else

275− Just $ DockerInvalidStatusCode st

276−statusCodeToError (DeleteImageEndpoint _ _) st =

277− if st == status200 then

278− Nothing

279− else

280− Just $ DockerInvalidStatusCode st

281−statusCodeToError (CreateNetworkEndpoint _) st =

282− if st == status201 then

283− Nothing

284− else

285− Just $ DockerInvalidStatusCode st

286−statusCodeToError (RemoveNetworkEndpoint _) st =

287− if st == status204 then

288− Nothing

289− else

290− Just $ DockerInvalidStatusCode st

src/Docker/Client/Internal.hs+28−59

@@ -1,17 +1,14 @@

1module Docker.Client.Internal where

3import Blaze.ByteString.Builder (toByteString)

4import Blaze.ByteString.Builder (toByteString)

4import qualified Data.Aeson as JSON

5import qualified Data.Aeson as JSON

5import Data.ByteString (ByteString)

6import Data.ByteString (ByteString)

6−import qualified Data.ByteString.Char8 as BSC

7+import qualified Data.ByteString.Lazy as BSL

7−import qualified Data.Conduit.Binary as CB

8−import qualified Data.Text as T

8+import Data.Text as T

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

10−import qualified Network.HTTP.Client as HTTP

11−import Network.HTTP.Conduit (requestBodySourceChunked)

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

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

13 encodePathSegments)

11 encodePathSegments)

14−import Prelude hiding (all)

16import Docker.Client.Types

13import Docker.Client.Types

@@ -25,65 +22,49 @@ encodeURLWithQuery ps q = decodeUtf8 $ toByteString $ encodePath ps q

25encodeQ :: String -> ByteString

22encodeQ :: String -> ByteString

26encodeQ = encodeUtf8 . T.pack

23encodeQ = encodeUtf8 . T.pack

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

25+getEndpoint :: Endpoint -> T.Text

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

26+getEndpoint VersionEndpoint = encodeURL ["version"]

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

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

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

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

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

29+getEndpoint (CreateContainerEndpoint _ cn) = case cn of

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

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

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

31+ Nothing -> encodeURL ["containers", "create"]

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

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

36 where query = case (detachKeys startOpts) of

33 where query = case (detachKeys startOpts) of

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

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

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

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

39 DefaultDetachKey -> []

36 DefaultDetachKey -> []

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

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

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

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

42 where query = case t of

39 where query = case t of

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

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

44 DefaultTimeout -> []

41 DefaultTimeout -> []

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

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

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

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

47 where query = case s of

44 where query = case s of

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

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

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

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

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

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

51 where query = case t of

48 where query = case t of

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

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

53 DefaultTimeout -> []

50 DefaultTimeout -> []

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

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

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

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

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

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

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

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

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

55+ encodeURLWithQuery ["containers", fromContainerID cid, "logs"] query

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

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

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

57+getEndpoint (DeleteContainerEndpoint (DeleteOpts removeVolumes force) cid) =

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

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

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

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

63−getEndpoint v (InspectContainerEndpoint cid) =

60+getEndpoint (InspectContainerEndpoint cid) =

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

61+ encodeURLWithQuery ["containers", fromContainerID cid, "json"] []

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

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

67− t = encodeQ $ T.unpack $ buildImageName o

68− dockerfile = encodeQ $ T.unpack $ buildDockerfileName o

69− q = encodeQ $ show $ buildQuiet o

70− nocache = encodeQ $ show $ buildNoCache o

71− rm = encodeQ $ show $ buildRemoveItermediate o

72− forcerm = encodeQ $ show $ buildForceRemoveIntermediate o

73− pull = encodeQ $ show $ buildPullParent o

74−getEndpoint v (CreateImageEndpoint name tag _) = encodeURLWithQuery [v, "images", "create"] query

75− where query = [("fromImage", Just n), ("tag", Just t)]

76− n = encodeQ $ T.unpack name

77− t = encodeQ $ T.unpack tag

78−getEndpoint v (DeleteImageEndpoint _ cid) = encodeURL [v, "images", fromImageID cid]

79−getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"]

80−getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid]

82−getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

63+getEndpointRequestBody :: Endpoint -> Maybe BSL.ByteString

83getEndpointRequestBody VersionEndpoint = Nothing

64getEndpointRequestBody VersionEndpoint = Nothing

84getEndpointRequestBody (ListContainersEndpoint _) = Nothing

65getEndpointRequestBody (ListContainersEndpoint _) = Nothing

85getEndpointRequestBody (ListImagesEndpoint _) = Nothing

66getEndpointRequestBody (ListImagesEndpoint _) = Nothing

86−getEndpointRequestBody (CreateContainerEndpoint opts _) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)

67+getEndpointRequestBody (CreateContainerEndpoint opts _) = Just $ JSON.encode opts

87getEndpointRequestBody (StartContainerEndpoint _ _) = Nothing

68getEndpointRequestBody (StartContainerEndpoint _ _) = Nothing

88getEndpointRequestBody (StopContainerEndpoint _ _) = Nothing

69getEndpointRequestBody (StopContainerEndpoint _ _) = Nothing

89getEndpointRequestBody (WaitContainerEndpoint _) = Nothing

70getEndpointRequestBody (WaitContainerEndpoint _) = Nothing

@@ -94,15 +75,3 @@ getEndpointRequestBody (UnpauseContainerEndpoint _) = Nothing

94getEndpointRequestBody (ContainerLogsEndpoint _ _ _) = Nothing

75getEndpointRequestBody (ContainerLogsEndpoint _ _ _) = Nothing

95getEndpointRequestBody (DeleteContainerEndpoint _ _) = Nothing

76getEndpointRequestBody (DeleteContainerEndpoint _ _) = Nothing

96getEndpointRequestBody (InspectContainerEndpoint _) = Nothing

77getEndpointRequestBody (InspectContainerEndpoint _) = Nothing

97−

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

99−getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing

100−getEndpointRequestBody (DeleteImageEndpoint _ _) = Nothing

101−

102−getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)

103−getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing

104−

105−getEndpointContentType :: Endpoint -> BSC.ByteString

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

107−getEndpointContentType _ = BSC.pack "application/json; charset=utf-8"

108−

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

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

11 , ImageID

12 , fromImageID

13 , toImageID

14− , NetworkID

15− , fromNetworkID

16− , toNetworkID

17 , Timeout(..)

14 , Timeout(..)

18 , StatusCode(..)

15 , StatusCode(..)

19 , Signal(..)

16 , Signal(..)

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

26 , ContainerPortInfo(..)

23 , ContainerPortInfo(..)

27 , Container(..)

24 , Container(..)

28 , ContainerState(..)

25 , ContainerState(..)

29− , State(..)

26+ , Status(..)

30 , Digest

27 , Digest

31 , Label(..)

28 , Label(..)

32 , Tag

29 , Tag

33 , Image(..)

30 , Image(..)

34− , Entrypoint(..)

35 , dropImagePrefix

31 , dropImagePrefix

36 , CreateOpts(..)

32 , CreateOpts(..)

37− , BuildOpts(..)

38− , defaultBuildOpts

39 , defaultCreateOpts

33 , defaultCreateOpts

40 , DetachKeys(..)

34 , DetachKeys(..)

41 , StartOpts(..)

35 , StartOpts(..)

42 , defaultStartOpts

36 , defaultStartOpts

43− , ContainerDeleteOpts(..)

37+ , DeleteOpts(..)

44− , defaultContainerDeleteOpts

38+ , defaultDeleteOpts

45− , ImageDeleteOpts(..)

46− , defaultImageDeleteOpts

47 , Timestamp

39 , Timestamp

48 , TailLogOpt(..)

40 , TailLogOpt(..)

49 , LogOpts(..)

41 , LogOpts(..)

50 , defaultLogOpts

42 , defaultLogOpts

51− , CreateNetworkOpts(..)

52− , defaultCreateNetworkOpts

53 , VolumePermission(..)

43 , VolumePermission(..)

54 , Bind(..)

44 , Bind(..)

55 , Volume(..)

45 , Volume(..)

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

75 , UTSMode(..)

65 , UTSMode(..)

76 , HostConfig(..)

66 , HostConfig(..)

77 , defaultHostConfig

67 , defaultHostConfig

78− , NetworkingConfig(..)

79− , EndpointConfig(..)

80 , Ulimit(..)

68 , Ulimit(..)

81 , ContainerResources(..)

69 , ContainerResources(..)

82 , defaultContainerResources

70 , defaultContainerResources

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

112import Data.Text (Text)

100import Data.Text (Text)

113import qualified Data.Text as T

101import qualified Data.Text as T

114import Data.Time.Clock (UTCTime)

102import Data.Time.Clock (UTCTime)

115−import qualified Data.Vector as V

116import GHC.Generics (Generic)

103import GHC.Generics (Generic)

117import Prelude hiding (all, tail)

104import Prelude hiding (all, tail)

118import Text.Read (readMaybe)

105import Text.Read (readMaybe)

@@ -132,13 +119,8 @@ data Endpoint =

132 | UnpauseContainerEndpoint ContainerID

119 | UnpauseContainerEndpoint ContainerID

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

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

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

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

135− | DeleteContainerEndpoint ContainerDeleteOpts ContainerID

122+ | DeleteContainerEndpoint DeleteOpts ContainerID

136 | InspectContainerEndpoint ContainerID

123 | InspectContainerEndpoint ContainerID

137− | BuildImageEndpoint BuildOpts FilePath

138− | CreateImageEndpoint T.Text Tag (Maybe T.Text) -- ^ Either pull an image from docker hub or imports an image from a tarball (or URL)

139− | DeleteImageEndpoint ImageDeleteOpts ImageID

140− | CreateNetworkEndpoint CreateNetworkOpts

141− | RemoveNetworkEndpoint NetworkID

142 deriving (Eq, Show)

124 deriving (Eq, Show)

143

125

144-- | We should newtype this

126-- | We should newtype this

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

213

195

214instance FromJSON Signal where

196instance FromJSON Signal where

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

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

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

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

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

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

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

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

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

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

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

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

221− parseJSON _ = fail "Unknown Signal"

203+ parseJSON _ = fail "Unknown Signal"

222

204

223instance ToJSON Signal where

205instance ToJSON Signal where

224− toJSON SIGHUP = "SIGHUP"

206+ toJSON SIGHUP = "SIGHUP"

225− toJSON SIGINT = "SIGINT"

207+ toJSON SIGINT = "SIGINT"

226 toJSON SIGQUIT = "SIGQUIT"

208 toJSON SIGQUIT = "SIGQUIT"

227 toJSON SIGSTOP = "SIGSTOP"

209 toJSON SIGSTOP = "SIGSTOP"

228 toJSON SIGTERM = "SIGTERM"

210 toJSON SIGTERM = "SIGTERM"

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

250 , processLabel :: Text

232 , processLabel :: Text

251 , resolveConfPath :: FilePath

233 , resolveConfPath :: FilePath

252 , restartCount :: Int

234 , restartCount :: Int

253− , containerDetailsState :: ContainerState

235+ , state :: ContainerState

254 , mounts :: [Mount]

236 , mounts :: [Mount]

255 }

237 }

256 deriving (Eq, Show, Generic)

238 deriving (Eq, Show, Generic)

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

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

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

259-- list.

241-- list.

260data Mount = Mount {

242data Mount = Mount {

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

243+ mountName :: Text

262 , mountSource :: FilePath

244 , mountSource :: FilePath

263 , mountDestination :: FilePath

245 , mountDestination :: FilePath

264− , mountDriver :: Maybe Text

246+ , mountDriver :: Text

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

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

266 , mountRW :: Bool

248 , mountRW :: Bool

267 , mountPropogation :: Text

249 , mountPropogation :: Text

268 }

250 }

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

270

252

271instance FromJSON Mount where

253instance FromJSON Mount where

272 parseJSON (JSON.Object o) = do

254 parseJSON (JSON.Object o) = do

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

255+ name <- o .: "Name"

274 src <- o .: "Source"

256 src <- o .: "Source"

275 dest <- o .: "Destination"

257 dest <- o .: "Destination"

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

258+ driver <- o .: "Driver"

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

259+ mode <- o .: "Mode"

278 rw <- o .: "RW"

260 rw <- o .: "RW"

279 prop <- o .: "Propagation"

261 prop <- o .: "Propagation"

280− return $ Mount name src dest driver rw prop

262+ return $ Mount name src dest driver mode rw prop

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

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

282

264

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

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

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

293 , restarting :: Bool

275 , restarting :: Bool

294 , running :: Bool

276 , running :: Bool

295 , startedAt :: UTCTime

277 , startedAt :: UTCTime

296− , state :: State

278+ , status :: Status

297 }

279 }

298 deriving (Eq, Show, Generic)

280 deriving (Eq, Show, Generic)

299

281

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

523 , containerImageId :: ImageID

505 , containerImageId :: ImageID

524 , containerCommand :: Text

506 , containerCommand :: Text

525 , containerCreatedAt :: Int

507 , containerCreatedAt :: Int

526− , containerState :: State

527− , containerStatus :: Maybe Text

508+ , containerStatus :: Status

528 , containerPorts :: [ContainerPortInfo]

509 , containerPorts :: [ContainerPortInfo]

529 , containerLabels :: [Label]

510 , containerLabels :: [Label]

530 , containerNetworks :: [Network]

511 , containerNetworks :: [Network]

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

532 } deriving (Show, Eq)

513 } deriving (Show, Eq)

533

514

534instance FromJSON Container where

515instance FromJSON Container where

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

516+ parseJSON (JSON.Object v) =

536− Container <$> parseJSON o

517+ Container <$> (v .: "Id")

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

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

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

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

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

520+ <*> (v .: "ImageID")

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

521+ <*> (v .: "Command")

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

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

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

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

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

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

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

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

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

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

549 parseNetworks (JSON.Object v) =

529 parseNetworks (JSON.Object v) =

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

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

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

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

532+

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

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

553

534

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

535+-- | Represents the status of the container life cycle.

556 deriving (Eq, Show, Generic)

537 deriving (Eq, Show, Generic)

557

538

558−instance FromJSON State where

539+instance FromJSON Status where

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

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

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

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

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

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

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

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

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

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

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

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

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

546+ parseJSON _ = fail "Unknown Status"

566

547

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

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

568-- some validation.

549-- some validation.

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

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

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

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

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

625

606

626−-- | Alias for Aliases.

627−type Alias = Text

628−

629−-- | EndpointsConfig is container configuration for a specific network

630−newtype EndpointConfig = EndpointConfig [Alias] deriving (Eq, Show)

631−

632−instance ToJSON EndpointConfig where

633− toJSON (EndpointConfig aliases) = JSON.object

634− [ "Aliases" .= aliases

635− ]

636−

637−-- | Alias for endpoint name

638−type EndpointName = Text

639−

640−-- | Data type for the NetworkingConfig section of the container settings

641−newtype NetworkingConfig = NetworkingConfig

642− { endpointsConfig :: HM.HashMap EndpointName EndpointConfig

643− } deriving (Eq, Show)

644−

645−instance ToJSON NetworkingConfig where

646− toJSON (NetworkingConfig endpointsConfig) = JSON.object

647− [ "EndpointsConfig" .= endpointsConfig

648− ]

649

607

650-- | Options used for creating a Container.

608-- | Options used for creating a Container.

651data CreateOpts = CreateOpts {

609data CreateOpts = CreateOpts {

652− containerConfig :: ContainerConfig

610+ containerConfig :: ContainerConfig

653− , hostConfig :: HostConfig

611+ , hostConfig :: HostConfig

654− , networkingConfig :: NetworkingConfig

655 } deriving (Eq, Show)

612 } deriving (Eq, Show)

656

613

657instance ToJSON CreateOpts where

614instance ToJSON CreateOpts where

658− toJSON (CreateOpts cc hc nc) = do

615+ toJSON (CreateOpts cc hc) = do

659 let ccJSON = toJSON cc

616 let ccJSON = toJSON cc

660 let hcJSON = toJSON hc

617 let hcJSON = toJSON hc

661 case ccJSON of

618 case ccJSON of

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

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

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

620+ JSON.Object $ HM.insert "HostConfig" hcJSON o

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

665− JSON.Object o2

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

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

667

622

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

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

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

684 , cmd=[]

639 , cmd=[]

685 , volumes=[]

640 , volumes=[]

686 , workingDir=Nothing

641 , workingDir=Nothing

687− , entrypoint=Entrypoint []

642+ , entrypoint=Nothing

688 , networkDisabled=Nothing

643 , networkDisabled=Nothing

689 , macAddress=Nothing

644 , macAddress=Nothing

690 , labels=[]

645 , labels=[]

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

697 binds=[]

652 binds=[]

698 , containerIDFile=Nothing

653 , containerIDFile=Nothing

699 , logConfig=LogDriverConfig JsonFile []

654 , logConfig=LogDriverConfig JsonFile []

700− , networkMode=NetworkBridge

655+ , networkMode=Bridge

701 , portBindings=[]

656 , portBindings=[]

702 , restartPolicy=RestartOff

657 , restartPolicy=RestartOff

703 , volumeDriver=Nothing

658 , volumeDriver=Nothing

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

737 , memory=Nothing

692 , memory=Nothing

738 , memoryReservation=Nothing

693 , memoryReservation=Nothing

739 , memorySwap=Nothing

694 , memorySwap=Nothing

740− , oomKillDisable=Just False

695+ , oomKillDisable=False

741 , ulimits=[]

696 , ulimits=[]

742 }

697 }

743

698

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

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

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

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

746defaultCreateOpts :: T.Text -> CreateOpts

701defaultCreateOpts :: T.Text -> CreateOpts

747−defaultCreateOpts imageName = CreateOpts

748− { containerConfig = defaultContainerConfig imageName

702+defaultCreateOpts imageName = CreateOpts { containerConfig = defaultContainerConfig imageName, hostConfig = defaultHostConfig }

749− , hostConfig = defaultHostConfig

750− , networkingConfig = NetworkingConfig HM.empty

751− }

752

703

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

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

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

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

@@ -762,45 +713,16 @@ defaultStartOpts :: StartOpts

762defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }

713defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }

763

714

764-- | Options for deleting a container.

715-- | Options for deleting a container.

765−data ContainerDeleteOpts = ContainerDeleteOpts {

716+data DeleteOpts = DeleteOpts {

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

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

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

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

768 } deriving (Eq, Show)

719 } deriving (Eq, Show)

769

720

770−-- TODO: Add support for container build constraints

771−-- | Options for when building images from a Dockerfile

772−data BuildOpts = BuildOpts {

773− buildImageName :: Text -- ^ Image name in the form of name:tag; ie. myimage:latest.:w

774− , buildDockerfileName :: Text -- ^ Name of dockerfile (default: Dockerfile)

775− , buildQuiet :: Bool

776− , buildNoCache :: Bool -- ^ Do not use cache when building the image.

777− , buildRemoveItermediate :: Bool -- ^ Remove intermediate containers after a successful build (default true).

778− , buildForceRemoveIntermediate :: Bool -- ^ Always remove intermediate containers.

779− , buildPullParent :: Bool -- ^ Always attempt to pull a newer version of the *parent* image (ie. FROM debian:jessie).

780− } deriving (Eq, Show)

781−

782−defaultBuildOpts :: Text -> BuildOpts

783−defaultBuildOpts nameTag = BuildOpts { buildImageName = nameTag

784− , buildDockerfileName = "Dockerfile"

785− , buildQuiet = False

786− , buildNoCache = False

787− , buildRemoveItermediate = True

788− , buildForceRemoveIntermediate = False

789− , buildPullParent = False

790− }

791−

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

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

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

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

794-- running.

723-- running.

795−defaultContainerDeleteOpts :: ContainerDeleteOpts

724+defaultDeleteOpts :: DeleteOpts

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

725+defaultDeleteOpts = DeleteOpts { deleteVolumes = False, force = False }

797−

798−-- | Image delete opts

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

800−

801−-- | Sane image deletion defaults

802−defaultImageDeleteOpts :: ImageDeleteOpts

803−defaultImageDeleteOpts = ImageDeleteOpts

804

726

805-- | Timestamp alias.

727-- | Timestamp alias.

806type Timestamp = Integer

728type Timestamp = Integer

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

828 , tail = All

750 , tail = All

829 }

751 }

830

752

831−-- | Options for creating a network

832−data CreateNetworkOpts = CreateNetworkOpts

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

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

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

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

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

838− } deriving (Eq, Show)

839−

840−-- | Sensible defalut for create network options

841−defaultCreateNetworkOpts :: Text -> CreateNetworkOpts

842−defaultCreateNetworkOpts name =

843− CreateNetworkOpts

844− { createNetworkName = name

845− , createNetworkCheckDuplicate = False

846− , createNetworkDriver = "bridge"

847− , createNetworkInternal = True

848− , createNetworkEnableIPv6 = False

849− }

850−

851−instance ToJSON CreateNetworkOpts where

852− toJSON opts =

853− object

854− [ "Name" .= createNetworkName opts

855− , "CheckDuplicate" .= createNetworkCheckDuplicate opts

856− , "Driver" .= createNetworkDriver opts

857− , "Internal" .= createNetworkInternal opts

858− , "EnableIPv6" .= createNetworkEnableIPv6 opts

859− ]

860−

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

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

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

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

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

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

864

756

865instance ToJSON VolumePermission where

757instance ToJSON VolumePermission where

866 toJSON ReadWrite = "rw"

758 toJSON ReadWrite = "rw"

867− toJSON ReadOnly = "ro"

759+ toJSON ReadOnly = "ro"

868

760

869instance FromJSON VolumePermission where

761instance FromJSON VolumePermission where

870 parseJSON "rw" = return ReadWrite

762 parseJSON "rw" = return ReadWrite

871 parseJSON "ro" = return ReadOnly

763 parseJSON "ro" = return ReadOnly

872− parseJSON "RW" = return ReadWrite

873− parseJSON "RO" = return ReadOnly

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

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

875

765

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

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

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

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

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

893

783

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

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

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

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

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

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

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

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

898

788

899

789

900data Bind = Bind { hostSrc :: Text

790data Bind = Bind { hostSrc :: Text

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

904

794

905instance FromJSON Bind where

795instance FromJSON Bind where

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

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

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

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

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

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

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

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

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

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

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

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

912

802

913data Device = Device {

803data Device = Device {

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

930

820

931instance FromJSON VolumeFrom where

821instance FromJSON VolumeFrom where

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

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

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

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

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

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

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

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

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

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

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

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

938

828

939instance ToJSON VolumeFrom where

829instance ToJSON VolumeFrom where

940 toJSON (VolumeFrom n p) = case p of

830 toJSON (VolumeFrom n p) = case p of

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

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

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

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

943

833

944instance ToJSON Bind where

834instance ToJSON Bind where

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

950

840

951instance FromJSON Link where

841instance FromJSON Link where

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

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

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

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

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

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

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

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

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

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

957

847

958instance ToJSON Link where

848instance ToJSON Link where

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

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

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

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

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

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

962

852

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

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

965

855

966instance FromJSON LogDriverType where

856instance FromJSON LogDriverType where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

976− parseJSON _ = fail "Unknown LogDriverType"

866+ parseJSON _ = fail "Unknown LogDriverType"

977

867

978instance ToJSON LogDriverType where

868instance ToJSON LogDriverType where

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

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

980− toJSON Syslog = JSON.String "syslog"

870+ toJSON Syslog = JSON.String "syslog"

981− toJSON Journald = JSON.String "journald"

871+ toJSON Journald = JSON.String "journald"

982− toJSON Gelf = JSON.String "gelf"

872+ toJSON Gelf = JSON.String "gelf"

983− toJSON Fluentd = JSON.String "fluentd"

873+ toJSON Fluentd = JSON.String "fluentd"

984− toJSON AwsLogs = JSON.String "awslogs"

874+ toJSON AwsLogs = JSON.String "awslogs"

985− toJSON Splunk = JSON.String "splunk"

875+ toJSON Splunk = JSON.String "splunk"

986− toJSON Etwlogs = JSON.String "etwlogs"

876+ toJSON Etwlogs = JSON.String "etwlogs"

987 toJSON LoggingDisabled = JSON.String "none"

877 toJSON LoggingDisabled = JSON.String "none"

988

878

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

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

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

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

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

1018

908

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

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

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

910+data NetworkMode = Bridge | Host | NetworkDisabled

1021 deriving (Eq, Show, Ord)

911 deriving (Eq, Show, Ord)

1022

912

1023instance FromJSON NetworkMode where

913instance FromJSON NetworkMode where

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

914+ parseJSON (JSON.String "bridge") = return Bridge

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

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

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

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

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

1028− parseJSON _ = fail "Unknown NetworkMode"

917+ parseJSON _ = fail "Unknown NetworkMode"

1029

918

1030instance ToJSON NetworkMode where

919instance ToJSON NetworkMode where

1031− toJSON NetworkBridge = JSON.String "bridge"

920+ toJSON Bridge = JSON.String "bridge"

1032− toJSON NetworkHost = JSON.String "host"

921+ toJSON Host = JSON.String "host"

1033 toJSON NetworkDisabled = JSON.String "none"

922 toJSON NetworkDisabled = JSON.String "none"

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

1035−

1036−newtype NetworkID = NetworkID Text

1037− deriving (Eq, Show)

1038−

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

1040−fromNetworkID :: NetworkID -> Text

1041−fromNetworkID (NetworkID t) = t

1042−

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

1044−toNetworkID :: Text -> Maybe NetworkID

1045−toNetworkID t = Just $ NetworkID t

1046−

1047−instance FromJSON NetworkID where

1048− parseJSON (JSON.Object o) = do

1049− nid <- o .: "Id"

1050− return $ NetworkID nid

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

1052−

1053−instance ToJSON NetworkID where

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

1055

923

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

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

1057

925

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

1067 parseJSON val = case val of

935 parseJSON val = case val of

1068 "tcp" -> return TCP

936 "tcp" -> return TCP

1069 "udp" -> return UDP

937 "udp" -> return UDP

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

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

1071

939

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

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

1073--

941--

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

1197 "on-failure" -> do

1065 "on-failure" -> do

1198 retry <- o .: "MaximumRetryCount"

1066 retry <- o .: "MaximumRetryCount"

1199 return $ RestartOnFailure retry

1067 return $ RestartOnFailure retry

1200− "no" -> return RestartOff

1068+ "off" -> return RestartOff

1201 _ -> fail "Could not parse RestartPolicy"

1069 _ -> fail "Could not parse RestartPolicy"

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

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

1203

1071

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

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

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

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

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

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

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

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

1076+ toJSON RestartOff = object ["Name" .= JSON.String "off"]

1209

1077

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

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

1211

1079

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

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

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

1384

1252

1385instance ToJSON MemoryConstraint where

1253instance ToJSON MemoryConstraint where

1386− toJSON (MemoryConstraint x B) = toJSON x

1254+ toJSON (MemoryConstraint x B) = toJSON x

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

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

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

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

1389

1257

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

1414 , memoryReservation :: Maybe MemoryConstraint

1282 , memoryReservation :: Maybe MemoryConstraint

1415 , memorySwap :: Maybe MemoryConstraint

1283 , memorySwap :: Maybe MemoryConstraint

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

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

1417− , oomKillDisable :: Maybe Bool

1285+ , oomKillDisable :: Bool

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

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

1419 , ulimits :: [Ulimit]

1287 , ulimits :: [Ulimit]

1420 -- TODO: Missing from 1.24

1288 -- TODO: Missing from 1.24

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

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

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

1453

1321

1454instance ToJSON EnvVar where

1322instance ToJSON EnvVar where

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

1323+ toJSON (EnvVar n v) = object [n .= v]

1456

1324

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

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

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

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

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

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

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

1493 slash = T.unpack "/"

1361 slash = T.unpack "/"

1494

1362

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−

1510data ContainerConfig = ContainerConfig {

1363data ContainerConfig = ContainerConfig {

1511 hostname :: Maybe Text

1364 hostname :: Maybe Text

1512 , domainname :: Maybe Text

1365 , domainname :: Maybe Text

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

1525 , image :: Text

1378 , image :: Text

1526 , volumes :: [Volume]

1379 , volumes :: [Volume]

1527 , workingDir :: Maybe FilePath

1380 , workingDir :: Maybe FilePath

1528− , entrypoint :: Entrypoint

1381+ , entrypoint :: Maybe Text -- Can be null?

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

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

1530 , macAddress :: Maybe Text

1383 , macAddress :: Maybe Text

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

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

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

1533 , stopSignal :: Signal

1386 , stopSignal :: Signal

1534 } deriving (Eq, Show, Generic)

1387 } deriving (Eq, Show, Generic)

1535

1388

1536−

1537instance ToJSON ContainerConfig where

1389instance ToJSON ContainerConfig where

1538 toJSON = genericToJSON defaultOptions {

1390 toJSON = genericToJSON defaultOptions {

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

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

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

1555 image <- o .: "Image"

1407 image <- o .: "Image"

1556 volumes <- o .: "Volumes"

1408 volumes <- o .: "Volumes"

1557 workingDir <- o .:? "WorkingDir"

1409 workingDir <- o .:? "WorkingDir"

1558− entrypoint <- o .: "Entrypoint"

1410+ entrypoint <- o .:? "Entrypoint"

1559 networkDisabled <- o .:? "networkDisabled"

1411 networkDisabled <- o .:? "networkDisabled"

1560 macAddress <- o .:? "MacAddress"

1412 macAddress <- o .:? "MacAddress"

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

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

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

1564 macAddress labels stopSignal

1416 macAddress labels stopSignal

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

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

1566

1418

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

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

1569−#else

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

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

1571−#endif

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

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

1573 Nothing ->

1421 Nothing ->

1574 fail "Could not parse Integer"

1422 fail "Could not parse Integer"

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

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

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

1591emptyJsonObject :: JSON.Value

1439emptyJsonObject :: JSON.Value

1592emptyJsonObject = JSON.Object HM.empty

1440emptyJsonObject = JSON.Object HM.empty

1441+

src/Docker/Client/Utils.hsdeleted−131

@@ -1,131 +0,0 @@

1−{-# LANGUAGE ExplicitForAll #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−

5−

6−module Docker.Client.Utils where

7−

8−import qualified Codec.Archive.Tar as Tar

9−import qualified Codec.Compression.GZip as GZip

10−import Control.Monad (filterM, liftM, unless)

11−import Control.Monad.IO.Class

12−import qualified Data.ByteString.Lazy as BS

13−import Data.Monoid ((<>))

14−import qualified Data.Text as T

15−import qualified Data.Text.IO as TIO

16−import qualified Data.UUID as UUID

17−import qualified Data.UUID.V4 as UUID

18−import System.Directory (doesDirectoryExist, doesFileExist,

19− getTemporaryDirectory)

20−import System.FilePath (isAbsolute, makeRelative, (</>))

21−import System.FilePath.Find (FilterPredicate,

22− RecursionPredicate, always,

23− fileName, find, (==?))

24−import System.FilePath.GlobPattern ((~~))

25−import System.IO.Error (tryIOError)

26−-- import System.IO.Temp (withSystemTempDirectory)

27−--

28−import Docker.Client.Http

29−

30−type File = FilePath

31−data DirTree = DirTree [File] [DirTree]

32−

33−

34−newtype ExclusionPattern = ExclusionPattern T.Text deriving (Eq, Show)

35−newtype InclusionPattern = InclusionPattern T.Text deriving (Eq, Show)

36−

37−data DockerIgnore = DockerIgnore { exclusionPatterns :: [ExclusionPattern]

38− , inclusionPatterns :: [InclusionPattern]

39− } deriving (Eq, Show)

40−

41−newtype BuildContextRootDir = BuildContextRootDir FilePath deriving (Eq, Show)

42−

43−makeBuildContext :: forall m. MonadIO m => BuildContextRootDir -> m (Either DockerError FilePath)

44−makeBuildContext base = liftIO $ tryIOError (makeBuildContext' base) >>= \res -> case res of

45− Left e -> return $ Left $ DockerClientError (T.pack $ show e)

46− Right c -> return $ Right c

47−

48−makeBuildContext' :: forall m. MonadIO m => BuildContextRootDir -> m FilePath

49−makeBuildContext' (BuildContextRootDir base) = do

50− uuid <- liftIO UUID.nextRandom

51− fs <- liftIO $ getBuildContext $ BuildContextRootDir base

52− let relFs = map (makeRelative base) fs

53− tmpDir <- liftIO getTemporaryDirectory

54− let tmpF = tmpDir </> "docker.context-" <> UUID.toString uuid <> ".tar.gz"

55− liftIO $ BS.writeFile tmpF . GZip.compress . Tar.write =<< Tar.pack base relFs

56− return tmpF

57−

58−parseDockerIgnoreFile :: T.Text -> DockerIgnore

59−parseDockerIgnoreFile c = DockerIgnore{ exclusionPatterns=parseExclusions

60− , inclusionPatterns=parseInclusions}

61− where lines = filter (not . T.isPrefixOf "#") (T.lines c) -- Ignore comments

62− parseExclusions = map ExclusionPattern $ filter (\l -> not (T.isPrefixOf "!" l) && (l /= "")) lines

63− parseInclusions = map (InclusionPattern . T.drop 1) $ filter (\l -> T.isPrefixOf "!" l && (l /= "")) lines

64−

65−getBuildContext :: BuildContextRootDir -> IO [FilePath]

66−getBuildContext (BuildContextRootDir base) = do

67− -- The base dir needs to be a path to a directory and not a path to

68− -- a file

69− exists <- doesDirectoryExist base

70− let abs = isAbsolute base

71− unless (exists && abs) $ fail "Path to context needs to be a directory that: exists, is readable, and is an absolute path."

72− di <- find always (fileName ==? ".dockerignore") base

73− dockerignore <- case di of

74− [] -> return $ DockerIgnore [] []

75− -- This should not return more than one result though

76− (x:_) -> do

77− c <- TIO.readFile x

78− return $ parseDockerIgnoreFile c

79− -- This will traverse the directory recursively

80− fs <- find (shouldRecurse dockerignore) (shouldInclude dockerignore) base

81− -- fs is a list of directories *and* files in those directories. So

82− -- an example result would look like ["/tmp/project/files",

83− -- "/tmp/project/files/file1.txt"] and we want just the individual

84− -- files otherwise tar duplicates them when making the archive.

85− fs' <- filterM doesFileExist fs

86− -- For some reason base is in there as well and we don't need that

87− return $ filter (not . (==) base) fs'

88−

89−shouldInclude :: DockerIgnore -> FilterPredicate

90−shouldInclude d = check `liftM` fileName

91− where check f = dockerIgnoreDecision (exclusionCheck f (exclusionPatterns d), inclusionCheck f (inclusionPatterns d))

92−

93−shouldRecurse :: DockerIgnore -> RecursionPredicate

94−shouldRecurse d = check `liftM` fileName

95− where check f = dockerIgnoreDecision (exclusionCheck f (exclusionPatterns d), inclusionCheck f (inclusionPatterns d))

96−

97−-- TODO: We don't handle precedence rules. For instance a dockerignore file

98−-- like this:

99−--

100−-- *.md

101−-- !README*.md

102−-- README-secret.md

103−--

104−-- Should result in no markdown files being included in the context except README files other

105−-- than README-secret.md. FIXME: OUR implementation would in fact include

106−-- README-secret.md as well!!!

107−--

108−-- Whereas this:

109−--

110−-- *.md

111−-- README-secret.md

112−-- !README*.md

113−--

114−-- Should result in all of the README files being included. The middle line has no effect

115−-- because !README*.md matches README-secret.md and comes last. Our

116−-- implementation will result in the same thing.

117−dockerIgnoreDecision :: (Bool, Bool) -> Bool

118−dockerIgnoreDecision p = case p of

119− -- If it's in any of the exclusion patterns but also

120− -- in any of the inclusion patterns then laeave it

121− (True, True) -> True

122− (True, False) -> False

123− (False, True) -> True

124− (False, False) -> True

125−

126−exclusionCheck :: FilePath -> [ExclusionPattern] -> Bool

127−exclusionCheck f ps = any id (map (\(ExclusionPattern p) -> f ~~ T.unpack p) ps)

128−

129−inclusionCheck :: FilePath -> [InclusionPattern] -> Bool

130−inclusionCheck f ps = any id (map (\(InclusionPattern p) -> f ~~ T.unpack p) ps)

131−

stack-7.10.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-6.30

4+resolver: lts-5.18

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: []

12+

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

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

11flags: {}

14flags: {}

13# Extra package databases containing global packages

16# Extra package databases containing global packages

14−extra-deps:

17+extra-package-dbs: []

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.yamldeleted−4

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

1−resolver: lts-9.4

2−packages:

3−- '.'

4−extra-deps: []

stack-8.0.yaml+1−2

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

1resolver: lts-7.12

2packages:

3- '.'

4−extra-deps:

4+extra-deps: []

5−- unliftio-core-0.1.1.0

stack-8.6.4.yamldeleted−4

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

1−resolver: lts-13.19

2−packages:

3−- '.'

4−extra-deps: []

stack-8.8.2.yamldeleted−5

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

1−resolver: lts-15.0

2−packages:

3−- '.'

4−extra-deps: []

5−

stack.yaml+1−1

@@ -1 +1 @@

1−stack-8.6.4.yaml

1+stack-7.10.yaml

tests/Dockerfile+1−1

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

1FROM debian:jessie

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

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

tests/tests.hs+75−231

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

3module Main where

5−import Data.Either (rights)

6−import Prelude hiding (all)

7import qualified Test.QuickCheck.Monadic as QCM

5import qualified Test.QuickCheck.Monadic as QCM

8import Test.Tasty

6import Test.Tasty

9import Test.Tasty.HUnit

7import Test.Tasty.HUnit

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

12import Control.Concurrent (threadDelay)

10import Control.Concurrent (threadDelay)

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

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

14−import Control.Monad (forM_)

15import Control.Monad.IO.Class

12import Control.Monad.IO.Class

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

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

17import qualified Data.Aeson as JSON

14import qualified Data.Aeson as JSON

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

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

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

20− _String, _Value)

21import qualified Data.ByteString as B

16import qualified Data.ByteString as B

22import qualified Data.ByteString.Char8 as C

17import qualified Data.ByteString.Char8 as C

23import qualified Data.ByteString.Lazy as BL

18import qualified Data.ByteString.Lazy as BL

24import qualified Data.HashMap.Strict as HM

19import qualified Data.HashMap.Strict as HM

25import Data.Int (Int)

20import Data.Int (Int)

26import qualified Data.Map as M

21import qualified Data.Map as M

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

22+import Data.Maybe (fromJust, isJust)

28import Data.Monoid

23import Data.Monoid

29import Data.Text (Text, unpack)

24import Data.Text (Text, unpack)

30−import qualified Data.Vector as V

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

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

32import Network.HTTP.Client (newManager)

26import Network.HTTP.Client (newManager)

33import Network.HTTP.Client.TLS

27import Network.HTTP.Client.TLS

34import Network.HTTP.Types.Status

28import Network.HTTP.Types.Status

35−import System.Directory (getCurrentDirectory)

36−import System.Environment (lookupEnv)

37import System.Process (system)

29import System.Process (system)

39import Docker.Client

31import Docker.Client

41-- opts = defaultClientOpts

33-- opts = defaultClientOpts

34+

42−testImageName = "docker-hs/test"

35+testImageName = "docker-hs-test"

43−imageToDeleteFullName = "hello-world:latest"

45toStrict1 = B.concat . BL.toChunks

37toStrict1 = B.concat . BL.toChunks

47−runDocker f

39+runDocker f = do

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

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

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

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

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

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

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

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

52− -- mgr <- newManager settings

44+ -- mgr <- newManager settings

53− = do

54− h <- defaultHttpHandler

55− runDockerT (defaultClientOpts, h) f

45+ runDockerT (defaultClientOpts, defaultHttpHandler) f

57testDockerVersion :: IO ()

47testDockerVersion :: IO ()

58−testDockerVersion =

48+testDockerVersion = runDocker $ do

59− runDocker $

60− do v <- getDockerVersion

49+ v <- getDockerVersion

61− lift $ assert $ isRight v

50+ lift $ assert $ isRight v

62−

63−testStopNonexisting :: IO ()

64−testStopNonexisting = runDocker $ do

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

66− lift $ assert $ isLeft res

68testFindImage :: IO ()

52testFindImage :: IO ()

69−testFindImage =

53+testFindImage = runDocker $ do

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

87 images <- listImages defaultListOpts >>= fromRight

54 images <- listImages defaultListOpts >>= fromRight

88− return $ listToMaybe

89− $ filter (elem imageToDeleteFullName . imageRepoTags) images

55+ let xs = filter ((== [imageFullName]) . imageRepoTags) images

90−

56+ lift $ assert $ length xs == 1

91−testListContainers :: IO ()

57+ where imageFullName = testImageName <> ":latest"

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

109testRunAndReadLog :: IO ()

59testRunAndReadLog :: IO ()

110−testRunAndReadLog = testRunAndReadLogHelper $ NetworkingConfig HM.empty

60+testRunAndReadLog = runDocker $ do

111−

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

112−testRunAndReadLogWithNetworking :: IO ()

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

114−

115−testRunAndReadLogHelper :: NetworkingConfig -> IO ()

116−testRunAndReadLogHelper networkingConfig =

117− runDocker $

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

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

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

121− c <- fromRight containerId

62+ c <- fromRight containerId

122− status1 <- startContainer defaultStartOpts c

63+ status1 <- startContainer defaultStartOpts c

123− _ <- inspectContainer c >>= fromRight

64+ _ <- inspectContainer c >>= fromRight

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

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

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

66+ lift $ assert $ status1 == Right ()

67+ status2 <- killContainer SIGTERM c

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

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

69+ lift $ assert $ status2 == Right ()

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

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

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

71+ status3 <- deleteContainer (DeleteOpts True True) c

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

72+ lift $ assert $ status3 == Right ()

130− mapM_ removeNetwork createdNetworks

131− where

132− isRightUnit (Right ()) = True

133− isRightUnit _ = False

134− networkNames = HM.keys $ endpointsConfig networkingConfig

135− createNetworkWithName name = createNetwork $

136− (defaultCreateNetworkOpts name) { createNetworkCheckDuplicate = True }

137−

138−testCreateRemoveNetwork :: IO ()

139−testCreateRemoveNetwork = do

140− runDocker $ do

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

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

143− nid <- fromRight createStatus

144− removeStatus <- removeNetwork nid

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

146

147testLogDriverOptionsJson :: TestTree

74testLogDriverOptionsJson :: TestTree

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

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

149− where

76+ where

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

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

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

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

152− test3 =

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

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

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

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

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

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

156− key1 = "some-key"

82+ key1 = "some-key"

157− val1 = "some-val"

83+ val1 = "some-val"

158− key2 = "some-key2"

84+ key2 = "some-key2"

159− val2 = "some-key2"

85+ val2 = "some-key2"

160

161testExposedPortsJson :: TestTree

87testExposedPortsJson :: TestTree

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

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

163− where

89+ where

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

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

165− testUDP =

166− testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty

91+ testUDP = testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty

167− sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP]

92+ sampleEP = [ExposedPort 80 TCP, ExposedPort 1337 UDP]

168

169testLabelsJson :: TestTree

94testLabelsJson :: TestTree

170−testLabelsJson = testGroup "Testing Labels JSON" [testLS1, testLS2, testOverride]

95+testLabelsJson = testGroup "Testing Labels JSON" [ testLS1, testLS2, testOverride ]

171− where

96+ where

172− testLS1 = testCase "test label key1" $ assert $ JSON.toJSON sampleLS ^. key key1 . _String == val1

97+ testLS1 = testCase "test label key1" $ assert $ JSON.toJSON sampleLS ^. key key1 . _String == val1

173− testLS2 = testCase "test label key2" $ assert $ JSON.toJSON sampleLS ^. key key2 . _String == val2

98+ testLS2 = testCase "test label key2" $ assert $ JSON.toJSON sampleLS ^. key key2 . _String == val2

174− testOverride =

175− testCase "test label override" $ assert $ JSON.toJSON [Label key1 val1, Label key1 "override"] ^.

99+ testOverride = testCase "test label override" $ assert $ JSON.toJSON [Label key1 val1, Label key1 "override"] ^. key key1 . _String == "override"

176− key key1 .

177− _String ==

178− "override"

179− sampleLS = [Label key1 val1, Label key2 val2]

100+ sampleLS = [Label key1 val1, Label key2 val2]

180− key1 = "com.example.some-label"

101+ key1 = "com.example.some-label"

181− val1 = "some-value"

102+ val1 = "some-value"

182− key2 = "something"

103+ key2 = "something"

183− val2 = "value"

104+ val2 = "value"

184

105

185testVolumesJson :: TestTree

106testVolumesJson :: TestTree

186−testVolumesJson = testGroup "Testing Volumes JSON" [testSample1, testSample2]

107+testVolumesJson = testGroup "Testing Volumes JSON" [ testSample1, testSample2 ]

187− where

108+ where

188− testSample1 =

189− testCase "Test exposing volume: /tmp" $ assert $ JSON.toJSON sampleVolumes ^. key "/tmp" . _Object ==

109+ testSample1 = testCase "Test exposing volume: /tmp" $ assert $ JSON.toJSON sampleVolumes ^. key "/tmp" . _Object == HM.empty

190− HM.empty

191− testSample2 =

192− testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON sampleVolumes ^. key "/opt" . _Object ==

110+ testSample2 = testCase "Test exposing volume: /opt" $ assert $ JSON.toJSON sampleVolumes ^. key "/opt" . _Object == HM.empty

193− HM.empty

194− sampleVolumes = [Volume "/tmp", Volume "/opt"]

111+ sampleVolumes = [Volume "/tmp", Volume "/opt"]

195−

196−testEntrypointJson :: TestTree

197−testEntrypointJson = testGroup "Testing ContainerConfig JSON" [testSample1, testSample2, testSample3, testSample4, testSample5]

198− where

199− testSample1 =

200− testCase "Test toJSON with empty entrypoint (null)" $ assert $ JSON.toJSON (Entrypoint []) ^. _Null == ()

201− testSample2 =

202− testCase "Test toJSON with entrypoint as Array" $ assert $

203− JSON.toJSON (Entrypoint sampleEntrypointArr) ==

204− JSON.toJSON sampleEntrypointArr

205− testSample3 =

206− testCase "Test decoding entrypoint as string" $ assert $ (JSON.decode "\"cmd\"") ==

207− Just (Entrypoint ["cmd"])

208− testSample4 =

209− testCase "Test decoding as null" $ assert $ (JSON.decode "null" :: Maybe Entrypoint) ==

210− Just (Entrypoint [])

211− testSample5 =

212− testCase "Test decoding as array" $ assert $ (JSON.decode (JSON.encode sampleEntrypointArr) :: Maybe Entrypoint) ==

213− Just (Entrypoint sampleEntrypointArr)

214− sampleEntrypointArr = ["cmd", "--some-flag", "--some-flag2"]

215−

216−testEnvVarJson :: TestTree

217−testEnvVarJson = testGroup "Testing EnvVar JSON" [testSampleEncode, testSampleDecode]

218− where

219− testSampleEncode =

220− testCase "Test toJSON" $ assert $ JSON.toJSON (EnvVar "cellar" "door") == JSON.String "cellar=door"

221− testSampleDecode =

222− testCase "Test fromJSON" $ assert $ (JSON.decode "\"cellar=door\"" :: Maybe EnvVar) ==

223− Just (EnvVar "cellar" "door")

224−

225−testNetworkingConfigJson :: TestTree

226−testNetworkingConfigJson = testGroup "Testing NetworkingConfig JSON" [testSampleEncode]

227− where

228− testSampleEncode =

229− let networkingConfig = NetworkingConfig $ HM.fromList [("custom-network", EndpointConfig ["cellar", "door"])]

230− in testCase "Test toJSON" $ assert $ JSON.toJSON networkingConfig ==

231− JSON.object

232− [ "EndpointsConfig" .= JSON.object

233− [ "custom-network" .= JSON.object

234− [ "Aliases" .= (["cellar", "door"] :: [Text])

235− ]

236− ]

237− ]

238

112

239integrationTests :: TestTree

113integrationTests :: TestTree

240−integrationTests =

114+integrationTests = testGroup "Integration Tests" [

241− testGroup

242− "Integration Tests"

243− [ testCase "Get docker version" testDockerVersion

115+ testCase "Get docker version" testDockerVersion,

244− , testCase "Build image from Dockerfile" testBuildFromDockerfile

245− , testCase "Find image by name" testFindImage

116+ testCase "Find image by name" testFindImage,

246− , testCase "Delete image" testDeleteImage

247− , testCase "List containers" testListContainers

248− , testCase "Run a dummy container and read its log" testRunAndReadLog

117+ testCase "Run a dummy container and read its log" testRunAndReadLog]

249− , testCase "Run a dummy container with networking and read its log" testRunAndReadLogWithNetworking

250− , testCase "Try to stop a container that doesn't exist" testStopNonexisting

251− , testCase "Create and remove a network" testCreateRemoveNetwork

252− ]

253

118

254jsonTests :: TestTree

119jsonTests :: TestTree

255−jsonTests =

120+jsonTests = testGroup "JSON Tests" [testExposedPortsJson, testVolumesJson, testLabelsJson, testLogDriverOptionsJson]

256− testGroup

257− "JSON Tests"

258− [ testExposedPortsJson

259− , testVolumesJson

260− , testLabelsJson

261− , testLogDriverOptionsJson

262− , testEntrypointJson

263− , testEnvVarJson

264− , testNetworkingConfigJson

265− ]

266

121

267setup :: IO ()

122setup :: IO ()

268−setup =

269− mapM_ system

270− [ "docker pull " ++ unpack imageToDeleteFullName

271− , "docker build -t " ++ unpack testImageName ++ " tests"

123+setup = system ("docker build -t "++unpack testImageName++" tests") >> return ()

272− ]

273−

274−isLeft = not . isRight

275

124

276−isRight (Left _) = False

125+isRight (Left _) = False

277isRight (Right _) = True

126isRight (Right _) = True

278

127

279−fromRight

280− :: (MonadIO m, Show l)

128+fromRight :: (MonadIO m, Show l) => Either l r -> m r

281− => Either l r -> m r

282fromRight (Left l) = do

129fromRight (Left l) = do

283− liftIO $ assertFailure $ "Left: " ++ show l

130+ liftIO $ assertFailure $ "Left: " ++ show l

284− undefined

131+ undefined

285fromRight (Right r) = return r

132fromRight (Right r) = return r

286

133

287main :: IO ()

134main :: IO ()

288main = do

135main = do

289− stackage <- lookupEnv "RUN_INTEGRATION_TESTS"

290− case stackage of

291− Nothing -> defaultMain $ testGroup "Tests" [jsonTests]

292− Just _ -> do

293− setup

136+ setup

294− defaultMain $ testGroup "Tests" [jsonTests, integrationTests]

137+ defaultMain $ testGroup "Tests" [jsonTests, integrationTests]

138+