2f728a7 · docker-hs · git.iko.soy

git.iko.soy/docker-hs

on master help sign in

Merge pull request #15 from denibertovic/dev

2f728a7Deni Bertovic10 years ago

.travis.yml+16−3

compare with master

unifiedsplit

@@ -1,9 +1,17 @@

1−sudo:

1+sudo: required

2− false

2+dist: trusty

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

4−language:

5+language:

5 c

6 c

8+# Caching so the next build will be fast too.

9+cache:

10+ directories:

11+ - $HOME/.ghc

12+ - $HOME/.cabal

13+ - $HOME/.stack

14+

7services:

15services:

8 - docker

16 - docker

@@ -16,6 +24,11 @@ addons:

16 - libgmp-dev

24 - libgmp-dev

18before_install:

26before_install:

27+ # Upgrade docker to 1.12

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

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

30+ - sudo apt-get update

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

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

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

20 - export PATH=$HOME/.local/bin:$PATH

33 - export PATH=$HOME/.local/bin:$PATH

LICENSE+1−1

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

3All rights reserved.

Makefile+4−5

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

1−.PHONY: test build upload dist repl sdist

1+.PHONY: test build repl release

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

@@ -11,9 +11,8 @@ repl:

11test:

12 @stack test

14−sdist:

14+release:

15+ @stack build --haddock

15 @stack sdist

16 @stack sdist

16−

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

17−upload: dist

18− @stack upload .stack-work/dist/x86_64-linux/Cabal-1.18.1.5/docker-${VERSION}.tar.gz

README.md+1−1

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

1−# Docker Remote API wrapper for Haskell

1+# An API client for docker written in Haskell

3Travis CI : [![Build Status](https://travis-ci.org/denibertovic/docker-hs.svg?branch=master)](https://travis-ci.org/denibertovic/docker-hs)

docker.cabal+9−11

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

1name: docker

2version: 0.3.0.0

3−synopsis: Haskell wrapper for Docker Remote API

3+synopsis: An API client for docker written in Haskell

4description: See README.md

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

6license: BSD3

7license-file: LICENSE

8−author: Deni Bertovic

8+author: Deni Bertovic <deni@denibertovic.com>, James Parker <jp@jamesparker.me>

9−maintainer: deni@denibertovic.com

9+maintainer: Deni Bertovic <deni@denibertovic.com>

10copyright: BSD3

11category: Network

12build-type: Simple

@@ -17,28 +17,21 @@ stability: experimental

17library

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

19 hs-source-dirs: src

20− exposed-modules: Docker, Docker.Types, Docker.Internal, Docker.Http

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

21 -- other-modules: Docker.Internal

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

23 , aeson

24 , blaze-builder

25 , bytestring

26 , containers

27− , connection

28 , data-default-class

27 , data-default-class

29− , exceptions

30 , http-client

28 , http-client

31 , http-types

29 , http-types

32− , lens

33− , lens-aeson

34− , lifted-base

35 , mtl

30 , mtl

36 , network >= 2.6

31 , network >= 2.6

37− , network-uri

38 , text

32 , text

39 , time

33 , time

40 , tls >= 1.3.7

34 , tls >= 1.3.7

41− , transformers

42 , unordered-containers

35 , unordered-containers

43 , x509

36 , x509

44 , x509-store

37 , x509-store

@@ -51,6 +44,9 @@ test-suite docker-hs-tests

51 , bytestring

44 , bytestring

52 , connection

45 , connection

53 , docker

46 , docker

47+ , aeson

48+ , containers

49+ , unordered-containers

54 , http-client

50 , http-client

55 , http-client-tls

51 , http-client-tls

56 , http-types

52 , http-types

@@ -58,6 +54,8 @@ test-suite docker-hs-tests

58 , tasty-hunit

54 , tasty-hunit

59 , tasty-quickcheck

55 , tasty-quickcheck

60 , text

56 , text

57+ , lens

58+ , lens-aeson

61 , transformers

59 , transformers

62 , QuickCheck

60 , QuickCheck

63 , process

61 , process

src/Docker/Client.hsnew file+13

@@ -0,0 +1,13 @@

1+{-# LANGUAGE ExplicitForAll #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

4+module Docker.Client (

5+ module Docker.Client.Api

6+ , module Docker.Client.Types

7+ , module Docker.Client.Http

8+ ) where

10+import Docker.Client.Api

11+import Docker.Client.Http

12+import Docker.Client.Types

13+

src/Docker.hs → src/Docker/Client/Api.hsrenamed+42−17

@@ -1,19 +1,8 @@

1{-# LANGUAGE ExplicitForAll #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4−module Docker (

4+module Docker.Client.Api (

5− runDockerT

6− , DockerT

7− , DockerError(..)

8− , DockerClientOpts(..)

9− , defaultClientOpts

10− , HttpHandler

11− , defaultHttpHandler

12− , httpHandler

13− , unixHttpHandler

14− , clientParamsWithClientAuthentication

15− , clientParamsSetCA

16− , getDockerVersion

5+ getDockerVersion

17 , listContainers

6 , listContainers

18 , listImages

7 , listImages

19 , createContainer

8 , createContainer

@@ -36,8 +25,8 @@ import qualified Data.Text as Text

36import Network.HTTP.Client (responseBody, responseStatus)

25import Network.HTTP.Client (responseBody, responseStatus)

37import Network.HTTP.Types (StdMethod (..))

26import Network.HTTP.Types (StdMethod (..))

39−import Docker.Http

28+import Docker.Client.Http

40−import Docker.Types

29+import Docker.Client.Types

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

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

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

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

@@ -69,44 +58,80 @@ parseResponse (Right response) =

69 Right r ->

58 Right r ->

70 return $ Right r

59 return $ Right r

61+-- | Gets the version of the docker engine remote API.

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

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

73getDockerVersion = requestHelper GET VersionEndpoint >>= parseResponse

63getDockerVersion = requestHelper GET VersionEndpoint >>= parseResponse

65+-- | Lists all running docker containers. Pass in 'defaultListOpts' {all

66+-- = True} to get a list of stopped containers as well.

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

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

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

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

70+-- | Lists all docker images.

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

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

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

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

74+-- | Creates a docker container but does *not* start it. See

75+-- "CreateOpts" for a list of options and you can use 'defaultCreateOpts'

76+-- for some sane defaults.

81createContainer :: forall m. Monad m => CreateOpts -> DockerT m (Either DockerError ContainerID)

77createContainer :: forall m. Monad m => CreateOpts -> DockerT m (Either DockerError ContainerID)

82createContainer opts = requestHelper POST (CreateContainerEndpoint opts) >>= parseResponse

78createContainer opts = requestHelper POST (CreateContainerEndpoint opts) >>= parseResponse

84−-- TODO: Is this the correct return type? XXX

80+-- | Start a container from a given "ContainerID" that we get from

85−-- convert status code to unit or error

81+-- 'createContainer'. See "StartOpts" for a list of configuration options

82+-- for starting a container. Use 'defaultStartOpts' for sane defaults.

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

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

87startContainer sopts cid = requestUnit POST $ StartContainerEndpoint sopts cid

84startContainer sopts cid = requestUnit POST $ StartContainerEndpoint sopts cid

86+-- | Attempts to stop a container with the given "ContainerID" gracefully

87+-- (SIGTERM).

88+-- The docker daemon will wait for the given "Tiemout" and then send

89+-- a SIGKILL killing the container.

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

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

90stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid

91stopContainer t cid = requestUnit POST $ StopContainerEndpoint t cid

93+-- | Sends a "Signal" to the container with the given "ContainerID". Same

94+-- as "stopContainer" but you choose the signal directly.

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

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

93killContainer s cid = requestUnit POST $ KillContainerEndpoint s cid

96killContainer s cid = requestUnit POST $ KillContainerEndpoint s cid

98+-- | Restarts a container with the given "ContainerID".

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

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

96restartContainer t cid = requestUnit POST $ RestartContainerEndpoint t cid

100restartContainer t cid = requestUnit POST $ RestartContainerEndpoint t cid

101

102+-- | Pauses a container with the given "ContainerID"

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

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

99pauseContainer cid = requestUnit POST $ PauseContainerEndpoint cid

104pauseContainer cid = requestUnit POST $ PauseContainerEndpoint cid

100

105

106+-- | Unpauses a container with the given "ContainerID".

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

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

102unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid

108unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid

103

109

110+-- | Deletes a container with the given "ContainerID".

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

112+-- defaults.

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

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

105deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid

114deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid

106

115

116+-- | Gets "ContainerDetails" for a given "ContainerID".

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

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

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

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

109

119

120+-- | Get's container's logs for a given "ContainerID".

121+-- This will only work with the "JsonFile" "LogDriverType" as the other driver types disable

122+-- this endpoint and it will return a "DockerError".

123+--

124+-- See "LogOpts" for options that you can pass and

125+-- 'defaultLogOpts' for sane defaults.

126+--

127+-- __NOTE__: Currently streaming logs is

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

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

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

131+-- which might block your application...so use with caution.

132+--

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

134+-- syslog) for creating your containers.

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

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

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

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

112

137

src/Docker/Http.hs → src/Docker/Client/Http.hsrenamed+4−3

@@ -1,7 +1,7 @@

1{-# LANGUAGE RankNTypes #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4−module Docker.Http where

4+module Docker.Client.Http where

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

7import qualified Data.ByteString.Char8 as BSC

@@ -36,9 +36,10 @@ import qualified Network.HTTP.Types as HTTP

36import qualified Network.Socket as S

37import qualified Network.Socket.ByteString as SBS

39+

39−import Docker.Internal (getEndpoint,

40+import Docker.Client.Internal (getEndpoint,

40 getEndpointRequestBody)

41 getEndpointRequestBody)

41−import Docker.Types (DockerClientOpts, Endpoint (..),

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

42 baseUrl)

43 baseUrl)

44type Request = HTTP.Request

45type Request = HTTP.Request

src/Docker/Internal.hs → src/Docker/Client/Internal.hsrenamed+4−2

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

1−module Docker.Internal where

1+module Docker.Client.Internal where

4import Blaze.ByteString.Builder (toByteString)

@@ -7,10 +7,12 @@ import Data.ByteString (ByteString)

7import qualified Data.ByteString.Lazy as BSL

8import Data.Text as T

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

10−import Docker.Types

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

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

12 encodePathSegments)

11 encodePathSegments)

13+import Docker.Client.Types

14+

15+

14encodeURL :: [T.Text] -> T.Text

16encodeURL :: [T.Text] -> T.Text

15encodeURL ps = decodeUtf8 $ toByteString $ encodePathSegments ps

17encodeURL ps = decodeUtf8 $ toByteString $ encodePathSegments ps

src/Docker/Types.hs → src/Docker/Client/Types.hsrenamed+198−84

@@ -1,7 +1,7 @@

1{-# LANGUAGE RecordWildCards #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4−module Docker.Types (

4+module Docker.Client.Types (

5 Endpoint(..)

6 , URL

7 , ApiVersion

@@ -34,6 +34,7 @@ module Docker.Types (

34 , StartOpts(..)

35 , defaultStartOpts

36 , DeleteOpts(..)

37+ , defaultDeleteOpts

37 , Timestamp

38 , Timestamp

38 , TailLogOpt(..)

39 , TailLogOpt(..)

39 , LogOpts(..)

40 , LogOpts(..)

@@ -49,7 +50,7 @@ module Docker.Types (

49 , LogDriverConfig(..)

50 , LogDriverConfig(..)

50 , NetworkMode(..)

51 , NetworkMode(..)

51 , PortType(..)

52 , PortType(..)

52− , NetworkInterface(..)

53+-- , NetworkInterface(..)

53 , Networks(..)

54 , Networks(..)

54 , NetworkSettings(..)

55 , NetworkSettings(..)

55 , NetworkOptions(..)

56 , NetworkOptions(..)

@@ -73,6 +74,8 @@ module Docker.Types (

73 , ContainerConfig(..)

74 , ContainerConfig(..)

74 , defaultContainerConfig

75 , defaultContainerConfig

75 , ExposedPorts(..)

76 , ExposedPorts(..)

77+ , DeviceWeight(..)

78+ , DeviceRate(..)

76 ) where

79 ) where

78import Data.Aeson (FromJSON, ToJSON, genericParseJSON,

81import Data.Aeson (FromJSON, ToJSON, genericParseJSON,

@@ -102,7 +105,8 @@ data Endpoint =

102 | RestartContainerEndpoint Timeout ContainerID

105 | RestartContainerEndpoint Timeout ContainerID

103 | PauseContainerEndpoint ContainerID

106 | PauseContainerEndpoint ContainerID

104 | UnpauseContainerEndpoint ContainerID

107 | UnpauseContainerEndpoint ContainerID

105− | ContainerLogsEndpoint LogOpts Bool ContainerID -- Second argument (Bool) is whether to follow.

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

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

106 | DeleteContainerEndpoint DeleteOpts ContainerID

110 | DeleteContainerEndpoint DeleteOpts ContainerID

107 | InspectContainerEndpoint ContainerID

111 | InspectContainerEndpoint ContainerID

108 deriving (Eq, Show)

112 deriving (Eq, Show)

@@ -253,7 +257,7 @@ data DockerClientOpts = DockerClientOpts {

253

257

254defaultClientOpts :: DockerClientOpts

258defaultClientOpts :: DockerClientOpts

255defaultClientOpts = DockerClientOpts {

259defaultClientOpts = DockerClientOpts {

256− apiVer = "v1.23"

260+ apiVer = "v1.24"

257 , baseUrl = "http://127.0.0.1:2375"

261 , baseUrl = "http://127.0.0.1:2375"

258 }

262 }

259

263

@@ -282,11 +286,8 @@ instance FromJSON DockerVersion where

282 parseJSON = genericParseJSON defaultOptions {

286 parseJSON = genericParseJSON defaultOptions {

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

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

284

288

285−-- instance ToJSON ContainerDetails where

286−-- toJSON = error "TODO"

287−

288instance FromJSON ContainerDetails where

289instance FromJSON ContainerDetails where

289− parseJSON (JSON.Object o) = do

290+ parseJSON v@(JSON.Object o) = do

290 appArmor <- o .: "AppArmorProfile"

291 appArmor <- o .: "AppArmorProfile"

291 args <- o .: "Args"

292 args <- o .: "Args"

292 config <- o .: "Config"

293 config <- o .: "Config"

@@ -296,7 +297,7 @@ instance FromJSON ContainerDetails where

296 hostnamePath <- o .: "HostnamePath"

297 hostnamePath <- o .: "HostnamePath"

297 hostsPath <- o .: "HostsPath"

298 hostsPath <- o .: "HostsPath"

298 logPath <- o .: "LogPath"

299 logPath <- o .: "LogPath"

299− id <- o .: "Id"

300+ id <- parseJSON v

300 image <- o .: "Image"

301 image <- o .: "Image"

301 mountLabel <- o .: "MountLabel"

302 mountLabel <- o .: "MountLabel"

302 name <- o .: "Name"

303 name <- o .: "Name"

@@ -396,24 +397,24 @@ instance FromJSON Networks where

396 parseJSON _ = fail "Networks is not an object"

397 parseJSON _ = fail "Networks is not an object"

397

398

398data NetworkSettings = NetworkSettings {

399data NetworkSettings = NetworkSettings {

399− networkSettingsBridge :: Text

400+ networkSettingsBridge :: Text

400− , networkSettingsSandboxId :: Text

401+ , networkSettingsSandboxId :: Text

401− , networkSettingsHairpinMode :: Bool

402+ , networkSettingsHairpinMode :: Bool

402− , networkSettingsLinkLocalIPv6Address :: Text

403+ , networkSettingsLinkLocalIPv6Address :: Text

403 , networkSettingsLinkLocalIPv6PrefixLen :: Int

404 , networkSettingsLinkLocalIPv6PrefixLen :: Int

404− , networkSettingsPorts :: [Port] -- TODO: 1.24 spec is unclear

405+ , networkSettingsPorts :: PortBindings

405− , networkSettingsSandboxKey :: Text

406+ , networkSettingsSandboxKey :: Text

406− , networkSettingsSecondaryIPAddresses :: Maybe [Text] -- TODO: 1.24 spec is unclear

407+ , networkSettingsSecondaryIPAddresses :: Maybe [Text] -- TODO: 1.24 spec is unclear

407 , networkSettingsSecondaryIPv6Addresses :: Maybe [Text] -- TODO: 1.24 spec is unclear

408 , networkSettingsSecondaryIPv6Addresses :: Maybe [Text] -- TODO: 1.24 spec is unclear

408− , networkSettingsEndpointID :: Text

409+ , networkSettingsEndpointID :: Text

409− , networkSettingsGateway :: Text

410+ , networkSettingsGateway :: Text

410− , networkSettingsGlobalIPv6Address :: Text

411+ , networkSettingsGlobalIPv6Address :: Text

411− , networkSettingsGlobalIPv6PrefixLen :: Int

412+ , networkSettingsGlobalIPv6PrefixLen :: Int

412− , networkSettingsIpAddress :: Text

413+ , networkSettingsIpAddress :: Text

413− , networkSettingsIpPrefixLen :: Int

414+ , networkSettingsIpPrefixLen :: Int

414− , networkSettingsIpv6Gateway

415+ , networkSettingsIpv6Gateway :: Text

415− , networkSettingsMacAddress

416+ , networkSettingsMacAddress :: Text

416− , networkSettingsNetworks :: Networks

417+ , networkSettingsNetworks :: Networks

417 }

418 }

418 deriving (Eq, Show)

419 deriving (Eq, Show)

419

420

@@ -424,7 +425,7 @@ instance FromJSON NetworkSettings where

424 hairpin <- o .: "HairpinMode"

425 hairpin <- o .: "HairpinMode"

425 localIP6 <- o .: "LinkLocalIPv6Address"

426 localIP6 <- o .: "LinkLocalIPv6Address"

426 localIP6Len <- o .: "LinkLocalIPv6PrefixLen"

427 localIP6Len <- o .: "LinkLocalIPv6PrefixLen"

427− ports <- o .:? "Ports" .!= []

428+ ports <- o .: "Ports" -- .!= []

428 sandboxKey <- o .: "SandboxKey"

429 sandboxKey <- o .: "SandboxKey"

429 secondaryIP <- o .: "SecondaryIPAddresses"

430 secondaryIP <- o .: "SecondaryIPAddresses"

430 secondayIP6 <- o .: "SecondaryIPv6Addresses"

431 secondayIP6 <- o .: "SecondaryIPv6Addresses"

@@ -438,7 +439,7 @@ instance FromJSON NetworkSettings where

438 mac <- o .: "MacAddress"

439 mac <- o .: "MacAddress"

439 networks <- o .: "Networks"

440 networks <- o .: "Networks"

440 return $ NetworkSettings bridge sandbox hairpin localIP6 localIP6Len ports sandboxKey secondaryIP secondayIP6 endpointID gateway globalIP6 globalIP6Len ip ipLen ip6Gateway mac networks

441 return $ NetworkSettings bridge sandbox hairpin localIP6 localIP6Len ports sandboxKey secondaryIP secondayIP6 endpointID gateway globalIP6 globalIP6Len ip ipLen ip6Gateway mac networks

441− parseJSON _ = fail "NetworkSettings is not an Object"

442+ parseJSON _ = fail "NetworkSettings is not an object."

442

443

443data Container = Container

444data Container = Container

444 { containerId :: ContainerID

445 { containerId :: ContainerID

@@ -539,7 +540,7 @@ defaultContainerConfig imageName = ContainerConfig {

539 , attachStdout=False

540 , attachStdout=False

540 , image=imageName

541 , image=imageName

541 , attachStderr=False

542 , attachStderr=False

542− , exposedPorts=ExposedPorts M.empty

543+ , exposedPorts=Nothing -- ExposedPorts M.empty

543 , tty=False

544 , tty=False

544 , openStdin=False

545 , openStdin=False

545 , stdinOnce=False

546 , stdinOnce=False

@@ -548,7 +549,7 @@ defaultContainerConfig imageName = ContainerConfig {

548 , volumes=Nothing

549 , volumes=Nothing

549 , workingDir=Nothing

550 , workingDir=Nothing

550 , entrypoint=Nothing

551 , entrypoint=Nothing

551− , networkDisabled=False

552+ , networkDisabled=Nothing

552 , macAddress=Nothing

553 , macAddress=Nothing

553 , labels=Nothing

554 , labels=Nothing

554 , stopSignal=SIGTERM

555 , stopSignal=SIGTERM

@@ -575,7 +576,7 @@ defaultHostConfig = HostConfig {

575 , oomScoreAdj=Nothing

576 , oomScoreAdj=Nothing

576 , privileged=False

577 , privileged=False

577 , publishAllPorts=False

578 , publishAllPorts=False

578− , readOnlyRootfs=False

579+ , readonlyRootfs=False

579 , securityOpt=[]

580 , securityOpt=[]

580 , shmSize=Nothing

581 , shmSize=Nothing

581 , resources=defaultContainerResources

582 , resources=defaultContainerResources

@@ -616,10 +617,13 @@ defaultStartOpts :: StartOpts

616defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }

617defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }

617

618

618data DeleteOpts = DeleteOpts {

619data DeleteOpts = DeleteOpts {

619− deleteVolumes :: Bool

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

620− , force :: Bool

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

621 } deriving (Eq, Show)

622 } deriving (Eq, Show)

622

623

624+defaultDeleteOpts :: DeleteOpts

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

626+

623type Timestamp = Integer

627type Timestamp = Integer

624data TailLogOpt = Tail Integer | All deriving (Eq, Show)

628data TailLogOpt = Tail Integer | All deriving (Eq, Show)

625

629

@@ -804,14 +808,14 @@ instance FromJSON PortType where

804 "udp" -> return UDP

808 "udp" -> return UDP

805 _ -> fail "PortType: Invalid port type."

809 _ -> fail "PortType: Invalid port type."

806

810

807−newtype NetworkInterface = NetworkInterface Text deriving (Eq, Show)

811+-- newtype NetworkInterface = NetworkInterface Text deriving (Eq, Show)

808−

812+--

809−instance FromJSON NetworkInterface where

813+-- instance FromJSON NetworkInterface where

810− parseJSON (JSON.String v) = return $ NetworkInterface v

814+-- parseJSON (JSON.String v) = return $ NetworkInterface v

811− parseJSON _ = fail "Network interface is not a string."

815+-- parseJSON _ = fail "Network interface is not a string."

812−

816+--

813−instance ToJSON NetworkInterface where

817+-- instance ToJSON NetworkInterface where

814− toJSON (NetworkInterface i) = JSON.String i

818+-- toJSON (NetworkInterface i) = JSON.String i

815

819

816-- | This datastructure models mapping a Port from the container onto the

820-- | This datastructure models mapping a Port from the container onto the

817-- host system s that the service running in the container can be accessed from

821-- host system s that the service running in the container can be accessed from

@@ -824,7 +828,7 @@ newtype PortBindings = PortBindings [PortBinding]

824data PortBinding = PortBinding {

828data PortBinding = PortBinding {

825 containerPort :: Port

829 containerPort :: Port

826 , portType :: PortType

830 , portType :: PortType

827− , hostPorts :: HostPorts

831+ , hostPorts :: [HostPort]

828 } deriving (Eq, Show)

832 } deriving (Eq, Show)

829

833

830

834

@@ -854,37 +858,39 @@ instance ToJSON PortBindings where

854 toJSON (PortBindings []) = JSON.Object HM.empty

858 toJSON (PortBindings []) = JSON.Object HM.empty

855 toJSON (PortBindings (p:ps)) = toJSON (p:ps)

859 toJSON (PortBindings (p:ps)) = toJSON (p:ps)

856

860

857−data HostPort = HostPort NetworkInterface Port

861+data HostPort = HostPort {

862+ hostIp :: Text

863+ , hostPost :: Port

864+ }

858 deriving (Eq, Show)

865 deriving (Eq, Show)

859

866

860instance ToJSON HostPort where

867instance ToJSON HostPort where

861− toJSON (HostPort i p) = object ["HostPort" .= p, "HostIP" .= i]

868+ toJSON (HostPort i p) = object ["HostPort" .= show p, "HostIp" .= i]

862

869

863instance FromJSON HostPort where

870instance FromJSON HostPort where

864 parseJSON (JSON.Object o) = do

871 parseJSON (JSON.Object o) = do

865− p <- o .: "HostPort"

872+ p <- o .: "HostPort" >>= parseIntegerText

866− i <- o .: "HostIP"

873+ i <- o .: "HostIp"

867 return $ HostPort i p

874 return $ HostPort i p

868 parseJSON _ = fail "HostPort is not an object."

875 parseJSON _ = fail "HostPort is not an object."

869

876

870−newtype HostPorts = HostPorts [HostPort]

877+-- newtype HostPorts = HostPorts [HostPort]

871− deriving (Eq, Show)

878+-- deriving (Eq, Show)

872−

879+--

873−

874−instance ToJSON HostPorts where

880+-- instance ToJSON HostPorts where

875− toJSON (HostPorts hps) = toJSON hps

881+-- toJSON (HostPorts hps) = toJSON hps

876−

882+--

877−instance FromJSON HostPorts where

883+-- instance FromJSON HostPorts where

878− parseJSON (JSON.Object o) = do

884+-- parseJSON (JSON.Object o) = do

879− HostPorts <$> HM.foldlWithKey' f (return []) o

885+-- HostPorts <$> HM.foldlWithKey' f (return []) o

880−

886+--

881− where

887+-- where

882− f accM k v = do

888+-- f accM k v = do

883− acc <- accM

889+-- acc <- accM

884− p' <- parseJSON v

890+-- p' <- parseJSON v

885− p <- parseIntegerText p'

891+-- p <- parseIntegerText p'

886− return $ (HostPort (NetworkInterface k) p):acc

892+-- return $ (HostPort (NetworkInterface k) p):acc

887− parseJSON _ = fail "HostPorts is not an object"

893+-- parseJSON _ = fail $ "HostPorts is not an object"

888

894

889-- { "Name": "on-failure" , "MaximumRetryCount": 2}

895-- { "Name": "on-failure" , "MaximumRetryCount": 2}

890type RetryCount = Integer

896type RetryCount = Integer

@@ -899,7 +905,7 @@ instance FromJSON RestartPolicy where

899 "on-failure" -> do

905 "on-failure" -> do

900 retry <- o .: "MaximumRetryCount"

906 retry <- o .: "MaximumRetryCount"

901 return $ RestartOnFailure retry

907 return $ RestartOnFailure retry

902− "" -> return RestartOff -- Note: Is this correct? 1.24 spec is unclear.

908+ "off" -> return RestartOff

903 _ -> fail "Could not parse RestartPolicy"

909 _ -> fail "Could not parse RestartPolicy"

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

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

905

911

@@ -938,7 +944,7 @@ data HostConfig = HostConfig

938 -- , pidMode :: Text -- 1.24: Don't see pidMode, just pidsLimit

944 -- , pidMode :: Text -- 1.24: Don't see pidMode, just pidsLimit

939 , privileged :: Bool

945 , privileged :: Bool

940 , publishAllPorts :: Bool

946 , publishAllPorts :: Bool

941− , readOnlyRootfs :: Bool

947+ , readonlyRootfs :: Bool

942 , securityOpt :: [Text]

948 , securityOpt :: [Text]

943 -- , utsMode :: UTSMode -- 1.24: Don't see this

949 -- , utsMode :: UTSMode -- 1.24: Don't see this

944 , shmSize :: Maybe Integer

950 , shmSize :: Maybe Integer

@@ -948,12 +954,84 @@ data HostConfig = HostConfig

948 } deriving (Eq, Show, Generic)

954 } deriving (Eq, Show, Generic)

949

955

950instance FromJSON HostConfig where

956instance FromJSON HostConfig where

951− parseJSON = genericParseJSON defaultOptions {

957+ parseJSON v@(JSON.Object o) = HostConfig

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

958+ <$> o .: "Binds"

959+ <*> o .: "ContainerIDFile"

960+ <*> o .: "LogConfig"

961+ <*> o .: "NetworkMode"

962+ <*> o .: "PortBindings"

963+ <*> o .: "RestartPolicy"

964+ <*> o .: "VolumeDriver"

965+ <*> o .: "VolumesFrom"

966+ <*> o .: "CapAdd"

967+ <*> o .: "CapDrop"

968+ <*> o .: "Dns"

969+ <*> o .: "DnsOptions"

970+ <*> o .: "DnsSearch"

971+ <*> o .: "ExtraHosts"

972+ <*> o .: "IpcMode"

973+ <*> o .:? "Links" .!= []

974+ <*> o .: "OomScoreAdj"

975+ <*> o .: "Privileged"

976+ <*> o .: "PublishAllPorts"

977+ <*> o .: "ReadonlyRootfs"

978+ <*> o .: "SecurityOpt"

979+ <*> o .: "ShmSize"

980+ <*> parseJSON v

981+ parseJSON _ = fail "HostConfig is not an object."

953

982

954instance ToJSON HostConfig where

983instance ToJSON HostConfig where

955− toJSON = genericToJSON defaultOptions {

984+ toJSON HostConfig{..} =

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

985+ let arr = [

986+ "Binds" .= binds

987+ , "ContainerIDFile" .= containerIDFile

988+ , "LogConfig" .= logConfig

989+ , "NetworkMode" .= networkMode

990+ , "PortBindings" .= portBindings

991+ , "RestartPolicy" .= restartPolicy

992+ , "VolumeDriver" .= volumeDriver

993+ , "VolumesFrom" .= volumesFrom

994+ , "CapAdd" .= capAdd

995+ , "CapDrop" .= capDrop

996+ , "Dns" .= dns

997+ , "DnsOptions" .= dnsOptions

998+ , "DnsSearch" .= dnsSearch

999+ , "ExtraHosts" .= extraHosts

1000+ , "IpcMode" .= ipcMode

1001+ , "Links" .= links

1002+ , "OomScoreAdj" .= oomScoreAdj

1003+ , "Privileged" .= privileged

1004+ , "PublishAllPorts" .= publishAllPorts

1005+ , "ReadonlyRootfs" .= readonlyRootfs

1006+ , "SecurityOpt" .= securityOpt

1007+ , "ShmSize" .= shmSize

1008+ ]

1009+ in

1010+ object $ arr <> ( resourcesArr resources)

1011+

1012+ where

1013+ -- JP: Not sure if this is better than a separate ToJSON instance with a bunch of `HM.insert`s.

1014+ resourcesArr ContainerResources{..} = [

1015+ "CpuShares" .= cpuShares

1016+ , "BlkioWeight" .= blkioWeight

1017+ , "BlkioWeightDevice" .= blkioWeightDevice

1018+ , "BlkioDeviceReadBps" .= blkioDeviceReadBps

1019+ , "BlkioDeviceWriteBps" .= blkioDeviceWriteBps

1020+ , "BlkioDeviceReadIOps" .= blkioDeviceReadIOps

1021+ , "BlkioDeviceWriteIOps" .= blkioDeviceWriteIOps

1022+ , "CpuPeriod" .= cpuPeriod

1023+ , "CpusetCpus" .= cpusetCpus

1024+ , "CpusetMems" .= cpusetMems

1025+ , "Devices" .= devices

1026+ , "KernelMemory" .= kernelMemory

1027+ , "Memory" .= memory

1028+ , "MemoryReservation" .= memoryReservation

1029+ , "MemorySwap" .= memorySwap

1030+ , "OomKillDisable" .= oomKillDisable

1031+ , "Ulimits" .= ulimits

1032+ ]

1033+

1034+

957

1035

958

1036

959-- { "Name": <name>, "Soft": <soft limit>, "Hard": <hard limit> }

1037-- { "Name": <name>, "Soft": <soft limit>, "Hard": <hard limit> }

@@ -972,18 +1050,54 @@ instance ToJSON Ulimit where

972 toJSON = genericToJSON defaultOptions {

1050 toJSON = genericToJSON defaultOptions {

973 fieldLabelModifier = drop 5}

1051 fieldLabelModifier = drop 5}

974

1052

1053+data DeviceWeight = DeviceWeight {

1054+ deviceWeightPath :: FilePath

1055+ , deviceWeightWeight :: Text

1056+ }

1057+ deriving (Show, Eq)

1058+

1059+instance FromJSON DeviceWeight where

1060+ parseJSON (JSON.Object o) = DeviceWeight

1061+ <$> o .: "Path"

1062+ <*> o .: "Weight"

1063+ parseJSON _ = fail "DeviceWeight is not an object."

1064+

1065+instance ToJSON DeviceWeight where

1066+ toJSON (DeviceWeight p w) = object [

1067+ "Path" .= p

1068+ , "Weight" .= w

1069+ ]

1070+

1071+data DeviceRate = DeviceRate {

1072+ deviceRatePath :: FilePath

1073+ , deviceRateRate :: Text

1074+ }

1075+ deriving (Show, Eq)

1076+

1077+instance FromJSON DeviceRate where

1078+ parseJSON (JSON.Object o) = DeviceRate

1079+ <$> o .: "Path"

1080+ <*> o .: "Rate"

1081+ parseJSON _ = fail "DeviceRate is not an object."

1082+

1083+instance ToJSON DeviceRate where

1084+ toJSON (DeviceRate p r) = object [

1085+ "Path" .= p

1086+ , "Rate" .= r

1087+ ]

1088+

975data ContainerResources = ContainerResources {

1089data ContainerResources = ContainerResources {

976 cpuShares :: Maybe Integer

1090 cpuShares :: Maybe Integer

977 -- , cgroupParent :: Text -- 1.24: Missing from inspecting container details... Going to omit for now.

1091 -- , cgroupParent :: Text -- 1.24: Missing from inspecting container details... Going to omit for now.

978− , blkioWeight :: Maybe Text

1092+ , blkioWeight :: Maybe Integer

979− , blkioWeightDevice :: Maybe Text

1093+ , blkioWeightDevice :: Maybe [DeviceWeight]

980− , blkioDeviceReadBps :: Maybe Text

1094+ , blkioDeviceReadBps :: Maybe [DeviceRate] -- TODO: Not Text

981− , blkioDeviceWriteBps :: Maybe Text

1095+ , blkioDeviceWriteBps :: Maybe [DeviceRate] -- TODO: Not Text

982− , blkioDeviceReadIOps :: Maybe Text

1096+ , blkioDeviceReadIOps :: Maybe [DeviceRate] -- TODO: Not Text

983− , blkioDeviceWriteIOps :: Maybe Text

1097+ , blkioDeviceWriteIOps :: Maybe [DeviceRate] -- TODO: Not Text

984 , cpuPeriod :: Maybe Integer

1098 , cpuPeriod :: Maybe Integer

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

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

986− , cpusetCpus :: Maybe Integer

1100+ , cpusetCpus :: Maybe Text

987 , cpusetMems :: Maybe Text

1101 , cpusetMems :: Maybe Text

988 , devices :: [Device]

1102 , devices :: [Device]

989 -- , diskQuota :: Integer -- Don't see this ins 1.24.

1103 -- , diskQuota :: Integer -- Don't see this ins 1.24.

@@ -1006,13 +1120,13 @@ data ContainerResources = ContainerResources {

1006 -- LxcConf :: [??] +

1120 -- LxcConf :: [??] +

1007 } deriving (Eq, Show, Generic)

1121 } deriving (Eq, Show, Generic)

1008

1122

1009−instance ToJSON ContainerResources where

1123+-- instance ToJSON ContainerResources where

1010− toJSON = genericToJSON defaultOptions {

1124+-- toJSON = genericToJSON defaultOptions {

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

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

1012

1126

1013instance FromJSON ContainerResources where

1127instance FromJSON ContainerResources where

1014 parseJSON = genericParseJSON defaultOptions {

1128 parseJSON = genericParseJSON defaultOptions {

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

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

1016

1130

1017type Port = Integer

1131type Port = Integer

1018

1132

@@ -1074,7 +1188,7 @@ data ContainerConfig = ContainerConfig {

1074 , attachStdin :: Bool

1188 , attachStdin :: Bool

1075 , attachStdout :: Bool

1189 , attachStdout :: Bool

1076 , attachStderr :: Bool

1190 , attachStderr :: Bool

1077− , exposedPorts :: ExposedPorts

1191+ , exposedPorts :: Maybe ExposedPorts -- Note: Should we expand the JSON instance and take away the Maybe?

1078 -- , publishService :: Text -- Don't see this in 1.24

1192 -- , publishService :: Text -- Don't see this in 1.24

1079 , tty :: Bool

1193 , tty :: Bool

1080 , openStdin :: Bool

1194 , openStdin :: Bool

@@ -1086,9 +1200,9 @@ data ContainerConfig = ContainerConfig {

1086 , volumes :: Maybe Volumes

1200 , volumes :: Maybe Volumes

1087 , workingDir :: Maybe FilePath

1201 , workingDir :: Maybe FilePath

1088 , entrypoint :: Maybe Text -- Can be null?

1202 , entrypoint :: Maybe Text -- Can be null?

1089− , networkDisabled :: Bool

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

1090 , macAddress :: Maybe Text

1204 , macAddress :: Maybe Text

1091− -- , onBuild :: Text -- For 1.24, only see this in the inspect response.

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

1092 , labels :: Maybe Labels

1206 , labels :: Maybe Labels

1093 , stopSignal :: Signal

1207 , stopSignal :: Signal

1094 } deriving (Eq, Show, Generic)

1208 } deriving (Eq, Show, Generic)

@@ -1101,7 +1215,7 @@ instance FromJSON ContainerConfig where

1101 parseJSON = genericParseJSON defaultOptions {

1215 parseJSON = genericParseJSON defaultOptions {

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

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

1103

1217

1104−parseIntegerText :: (Monad m) =>Text -> m Integer

1218+parseIntegerText :: (Monad m) => Text -> m Integer

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

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

1106 Nothing ->

1220 Nothing ->

1107 fail "Could not parse Integer"

1221 fail "Could not parse Integer"

tests/tests.hs+40−22

@@ -5,26 +5,30 @@ module Main where

5import qualified Test.QuickCheck.Monadic as QCM

6import Test.Tasty

7import Test.Tasty.HUnit

8−import qualified Test.Tasty.QuickCheck as QC

8+import Test.Tasty.QuickCheck (testProperty)

10import Control.Concurrent (threadDelay)

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

11import Control.Monad.IO.Class

12import Control.Monad.IO.Class

12−import Control.Monad.Trans.Class (MonadTrans, lift)

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

14+import qualified Data.Aeson as JSON

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

13import qualified Data.ByteString as B

16import qualified Data.ByteString as B

14import qualified Data.ByteString.Char8 as C

17import qualified Data.ByteString.Char8 as C

15import qualified Data.ByteString.Lazy as BL

18import qualified Data.ByteString.Lazy as BL

19+import qualified Data.HashMap.Strict as HM

20+import Data.Int (Int)

21+import qualified Data.Map as M

16import Data.Maybe (fromJust, isJust)

22import Data.Maybe (fromJust, isJust)

17import Data.Monoid

23import Data.Monoid

18−import Data.Text (unpack)

24+import Data.Text (Text, unpack)

19import Network.Connection (TLSSettings (..))

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

20import Network.HTTP.Client (newManager)

26import Network.HTTP.Client (newManager)

21import Network.HTTP.Client.TLS

27import Network.HTTP.Client.TLS

22import Network.HTTP.Types.Status

28import Network.HTTP.Types.Status

23import System.Process (system)

29import System.Process (system)

25−import Docker

31+import Docker.Client

26−import Docker.Types

27−

29-- opts = defaultClientOpts

33-- opts = defaultClientOpts

@@ -40,22 +44,23 @@ runDocker f = do

40 -- mgr <- newManager settings

44 -- mgr <- newManager settings

41 runDockerT (defaultClientOpts, defaultHttpHandler) f

45 runDockerT (defaultClientOpts, defaultHttpHandler) f

43−checkDockerVersion :: IO ()

47+testDockerVersion :: IO ()

44−checkDockerVersion = runDocker $ do

48+testDockerVersion = runDocker $ do

45 v <- getDockerVersion

49 v <- getDockerVersion

46 lift $ assert $ isRight v

50 lift $ assert $ isRight v

48−findTestImage :: IO ()

52+testFindImage :: IO ()

49−findTestImage = runDocker $ do

53+testFindImage = runDocker $ do

50 images <- listImages defaultListOpts >>= fromRight

54 images <- listImages defaultListOpts >>= fromRight

51 let x = filter ((== [testImageName<>":latest"]) . imageRepoTags) images

55 let x = filter ((== [testImageName<>":latest"]) . imageRepoTags) images

52 lift $ assert $ length x == 1

56 lift $ assert $ length x == 1

54−runAndReadLog :: IO ()

58+testRunAndReadLog :: IO ()

55−runAndReadLog = runDocker $ do

59+testRunAndReadLog = runDocker $ do

56 containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest"))

60 containerId <- createContainer (defaultCreateOpts (testImageName <> ":latest"))

57 c <- fromRight containerId

61 c <- fromRight containerId

58 status1 <- startContainer defaultStartOpts c

62 status1 <- startContainer defaultStartOpts c

63+ _ <- inspectContainer c >>= fromRight

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

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

60 lift $ assert $ status1 == Right ()

65 lift $ assert $ status1 == Right ()

61 status2 <- killContainer SIGTERM c

66 status2 <- killContainer SIGTERM c

@@ -66,20 +71,27 @@ runAndReadLog = runDocker $ do

66 lift $ assert $ status3 == Right ()

71 lift $ assert $ status3 == Right ()

74+sampleEP = ExposedPorts $ M.fromList [(80, TCP), (1337, UDP)]

75+

76+testExposedPorts :: TestTree

77+testExposedPorts = testGroup "Testing ExposedPorts JSON" [ testTCP, testUDP ]

78+ where

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

80+ testUDP = testCase "udp port" $ assert $ JSON.toJSON sampleEP ^. key "1337/tcp" . _Object == HM.empty

81+

82+

69−tests :: TestTree

83+integrationTests :: TestTree

70−tests = testGroup "Metrics tests" [

84+integrationTests = testGroup "Integration Tests" [

71− testCase "Get docker version" checkDockerVersion,

85+ testCase "Get docker version" testDockerVersion,

72− testCase "Find image by name" findTestImage,

86+ testCase "Find image by name" testFindImage,

73− testCase "Run a dummy container and read its log" runAndReadLog]

87+ testCase "Run a dummy container and read its log" testRunAndReadLog]

88+

89+jsonTests :: TestTree

90+jsonTests = testGroup "JSON Tests" [testExposedPorts]

75setup :: IO ()

92setup :: IO ()

76setup = system ("docker build -t "++unpack testImageName++" tests") >> return ()

93setup = system ("docker build -t "++unpack testImageName++" tests") >> return ()

78−main :: IO ()

79−main = do

80− setup

81− defaultMain tests

82−

83isRight (Left _) = False

95isRight (Left _) = False

84isRight (Right _) = True

96isRight (Right _) = True

@@ -88,3 +100,9 @@ fromRight (Left l) = do

88 liftIO $ assertFailure $ "Left: " ++ show l

100 liftIO $ assertFailure $ "Left: " ++ show l

89 undefined

101 undefined

90fromRight (Right r) = return r

102fromRight (Right r) = return r

103+

104+main :: IO ()

105+main = do

106+ setup

107+ defaultMain $ testGroup "Tests" [jsonTests, integrationTests]

108+