781220a...master · docker-hs

git.iko.soy/docker-hs

on master help sign in

.travis.yml+8

since splitsnapshots

unifiedsplit

@@ -39,6 +39,14 @@ env:

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

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

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

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

45+

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

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

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

49+

42addons:

50addons:

43 apt:

51 apt:

44 packages:

52 packages:

CHANGELOG.md+24−1

@@ -1,6 +1,29 @@

1# CHANGELOG

3−## 0.5.0.2 (2018-02-21)

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

5+- Support for ghc 8.8.2.

6+- Bump dependency version.

7+- Use MonadFail for later versions.

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

10+

11+- Support ghc 8.6.4.

12+- Bump containers version.

13+

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

15+

16+- Rename DeleteOpts to ContainerDeleteOpts.

17+- Implement image deletion.

18+- Bump aeson version.

19+- Implement network aliases.

20+- Implement creating/deleting networks.

21+

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

23+

24+- Bump aeson version.

25+

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

5- Support http-conduit-2.3.0.

28- Support http-conduit-2.3.0.

6- Bump http-types versions.

29- Bump http-types versions.

docker.cabal+7−7

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

1name: docker

2−version: 0.5.0.2

2+version: 0.6.0.3

3synopsis: An API client for docker written in Haskell

4description: See API documentation below.

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

@@ -25,12 +25,12 @@ library

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

26 -- other-modules: Docker.Internal

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

28− , aeson >= 0.9.0 && < 1.3.0

28+ , aeson >= 0.9.0 && < 2.0.0

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

30 , bytestring >= 0.10.0 && < 0.11.0

31− , containers >= 0.5.0 && < 0.6.0

31+ , containers >= 0.5.0 && < 0.7.0

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

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

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

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

35 , vector

36 , conduit

@@ -51,15 +51,15 @@ library

51 , mtl >= 2.0.0 && < 3.0.0

52 , network >= 2.6.0

53 , text >= 1.0.0 && < 2.0.0

54− , time >= 1.5.0 && < 1.9.0

54+ , time >= 1.5.0 && < 2.0.0

55 , scientific >= 0.3.0 && < 0.4.0

56− , tls >= 1.3.7 && < 1.5.0

56+ , tls >= 1.3.7 && < 1.6.0

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

58 , x509 >= 1.6.0 && < 1.8.0

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

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

61 , http-conduit

62− , unliftio-core

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

src/Docker/Client/Api.hs+20−2

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

18 , getContainerLogsStream

19 -- * Images

20 , listImages

21+ , deleteImage

21 , buildImageFromDockerfile

22 , buildImageFromDockerfile

22 , pullImage

23 , pullImage

24+ -- * Network

25+ , createNetwork

26+ , removeNetwork

23 -- * Other

27 -- * Other

24 , getDockerVersion

28 , getDockerVersion

25 ) where

29 ) where

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

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

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

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

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

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

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

99+-- defaults.

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

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

102+

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

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

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

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

95-- for some sane defaults.

105-- for some sane defaults.

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

135unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid

145unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid

136

146

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

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

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

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

139-- defaults.

149-- defaults.

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

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

141deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid

151deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid

142

152

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

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

@@ -207,3 +217,11 @@ buildImageFromDockerfile opts base = do

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

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

208pullImage name tag = requestHelper' POST (CreateImageEndpoint name tag Nothing)

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

209

219

220+-- | Creates network

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

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

223+

224+-- | Removes a network

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

226+removeNetwork nid = requestUnit DELETE $ RemoveNetworkEndpoint nid

227+

src/Docker/Client/Http.hs+15−1

@@ -273,4 +273,18 @@ statusCodeToError (CreateImageEndpoint _ _ _) st =

273 Nothing

274 else

275 Just $ DockerInvalidStatusCode st

276−

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+8−1

@@ -57,7 +57,7 @@ getEndpoint v (UnpauseContainerEndpoint cid) = encodeURL [v, "containers", fromC

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

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

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

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

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

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

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

63getEndpoint v (InspectContainerEndpoint cid) =

@@ -75,6 +75,9 @@ getEndpoint v (CreateImageEndpoint name tag _) = encodeURLWithQuery [v, "images"

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]

79getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

82getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

80getEndpointRequestBody VersionEndpoint = Nothing

83getEndpointRequestBody VersionEndpoint = Nothing

@@ -94,6 +97,10 @@ getEndpointRequestBody (InspectContainerEndpoint _) = Nothing

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

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

96getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing

99getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing

100+getEndpointRequestBody (DeleteImageEndpoint _ _) = Nothing

101+

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

103+getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing

104

98getEndpointContentType :: Endpoint -> BSC.ByteString

105getEndpointContentType :: Endpoint -> BSC.ByteString

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

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

src/Docker/Client/Types.hs+114−11

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

11 , ImageID

12 , fromImageID

13 , toImageID

14+ , NetworkID

15+ , fromNetworkID

16+ , toNetworkID

14 , Timeout(..)

17 , Timeout(..)

15 , StatusCode(..)

18 , StatusCode(..)

16 , Signal(..)

19 , Signal(..)

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

37 , DetachKeys(..)

40 , DetachKeys(..)

38 , StartOpts(..)

41 , StartOpts(..)

39 , defaultStartOpts

42 , defaultStartOpts

40− , DeleteOpts(..)

43+ , ContainerDeleteOpts(..)

41− , defaultDeleteOpts

44+ , defaultContainerDeleteOpts

45+ , ImageDeleteOpts(..)

46+ , defaultImageDeleteOpts

42 , Timestamp

47 , Timestamp

43 , TailLogOpt(..)

48 , TailLogOpt(..)

44 , LogOpts(..)

49 , LogOpts(..)

45 , defaultLogOpts

50 , defaultLogOpts

51+ , CreateNetworkOpts(..)

52+ , defaultCreateNetworkOpts

46 , VolumePermission(..)

53 , VolumePermission(..)

47 , Bind(..)

54 , Bind(..)

48 , Volume(..)

55 , Volume(..)

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

68 , UTSMode(..)

75 , UTSMode(..)

69 , HostConfig(..)

76 , HostConfig(..)

70 , defaultHostConfig

77 , defaultHostConfig

78+ , NetworkingConfig(..)

79+ , EndpointConfig(..)

71 , Ulimit(..)

80 , Ulimit(..)

72 , ContainerResources(..)

81 , ContainerResources(..)

73 , defaultContainerResources

82 , defaultContainerResources

@@ -123,10 +132,13 @@ data Endpoint =

123 | UnpauseContainerEndpoint ContainerID

132 | UnpauseContainerEndpoint ContainerID

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

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

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

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

126− | DeleteContainerEndpoint DeleteOpts ContainerID

135+ | DeleteContainerEndpoint ContainerDeleteOpts ContainerID

127 | InspectContainerEndpoint ContainerID

136 | InspectContainerEndpoint ContainerID

128 | BuildImageEndpoint BuildOpts FilePath

137 | BuildImageEndpoint BuildOpts FilePath

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

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

130 deriving (Eq, Show)

142 deriving (Eq, Show)

131

143

132-- | We should newtype this

144-- | We should newtype this

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

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

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

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

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

613

625

626+-- | Alias for Aliases.

627+type Alias = Text

628+

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

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

631+

632+instance ToJSON EndpointConfig where

633+ toJSON (EndpointConfig aliases) = JSON.object

634+ [ "Aliases" .= aliases

635+ ]

636+

637+-- | Alias for endpoint name

638+type EndpointName = Text

639+

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

641+newtype NetworkingConfig = NetworkingConfig

642+ { endpointsConfig :: HM.HashMap EndpointName EndpointConfig

643+ } deriving (Eq, Show)

644+

645+instance ToJSON NetworkingConfig where

646+ toJSON (NetworkingConfig endpointsConfig) = JSON.object

647+ [ "EndpointsConfig" .= endpointsConfig

648+ ]

614

649

615-- | Options used for creating a Container.

650-- | Options used for creating a Container.

616data CreateOpts = CreateOpts {

651data CreateOpts = CreateOpts {

617− containerConfig :: ContainerConfig

652+ containerConfig :: ContainerConfig

618− , hostConfig :: HostConfig

653+ , hostConfig :: HostConfig

654+ , networkingConfig :: NetworkingConfig

619 } deriving (Eq, Show)

655 } deriving (Eq, Show)

620

656

621instance ToJSON CreateOpts where

657instance ToJSON CreateOpts where

622− toJSON (CreateOpts cc hc) = do

658+ toJSON (CreateOpts cc hc nc) = do

623 let ccJSON = toJSON cc

659 let ccJSON = toJSON cc

624 let hcJSON = toJSON hc

660 let hcJSON = toJSON hc

625 case ccJSON of

661 case ccJSON of

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

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

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

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

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

665+ JSON.Object o2

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

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

629

667

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

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

@@ -706,7 +744,11 @@ defaultContainerResources = ContainerResources {

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

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

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

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

708defaultCreateOpts :: T.Text -> CreateOpts

746defaultCreateOpts :: T.Text -> CreateOpts

747+defaultCreateOpts imageName = CreateOpts

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

748+ { containerConfig = defaultContainerConfig imageName

749+ , hostConfig = defaultHostConfig

750+ , networkingConfig = NetworkingConfig HM.empty

751+ }

710

752

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

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

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

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

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

720defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }

762defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }

721

763

722-- | Options for deleting a container.

764-- | Options for deleting a container.

723−data DeleteOpts = DeleteOpts {

765+data ContainerDeleteOpts = ContainerDeleteOpts {

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

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

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

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

726 } deriving (Eq, Show)

768 } deriving (Eq, Show)

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

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

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

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

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

752-- running.

794-- running.

753−defaultDeleteOpts :: DeleteOpts

795+defaultContainerDeleteOpts :: ContainerDeleteOpts

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

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

797+

798+-- | Image delete opts

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

800+

801+-- | Sane image deletion defaults

802+defaultImageDeleteOpts :: ImageDeleteOpts

803+defaultImageDeleteOpts = ImageDeleteOpts

755

804

756-- | Timestamp alias.

805-- | Timestamp alias.

757type Timestamp = Integer

806type Timestamp = Integer

@@ -779,6 +828,36 @@ defaultLogOpts = LogOpts { stdout = True

779 , tail = All

828 , tail = All

780 }

829 }

781

830

831+-- | Options for creating a network

832+data CreateNetworkOpts = CreateNetworkOpts

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

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

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

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

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

838+ } deriving (Eq, Show)

839+

840+-- | Sensible defalut for create network options

841+defaultCreateNetworkOpts :: Text -> CreateNetworkOpts

842+defaultCreateNetworkOpts name =

843+ CreateNetworkOpts

844+ { createNetworkName = name

845+ , createNetworkCheckDuplicate = False

846+ , createNetworkDriver = "bridge"

847+ , createNetworkInternal = True

848+ , createNetworkEnableIPv6 = False

849+ }

850+

851+instance ToJSON CreateNetworkOpts where

852+ toJSON opts =

853+ object

854+ [ "Name" .= createNetworkName opts

855+ , "CheckDuplicate" .= createNetworkCheckDuplicate opts

856+ , "Driver" .= createNetworkDriver opts

857+ , "Internal" .= createNetworkInternal opts

858+ , "EnableIPv6" .= createNetworkEnableIPv6 opts

859+ ]

860+

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

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

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

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

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

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

@@ -954,6 +1033,26 @@ instance ToJSON NetworkMode where

954 toJSON NetworkDisabled = JSON.String "none"

1033 toJSON NetworkDisabled = JSON.String "none"

955 toJSON (NetworkNamed n) = JSON.String n

1034 toJSON (NetworkNamed n) = JSON.String n

956

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+

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

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

958

1057

959instance Show PortType where

1058instance Show PortType where

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

1465 macAddress labels stopSignal

1564 macAddress labels stopSignal

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

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

1467

1566

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

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

1569+#else

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

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

1571+#endif

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

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

1470 Nothing ->

1573 Nothing ->

1471 fail "Could not parse Integer"

1574 fail "Could not parse Integer"

stack-7.10.yaml+4−1

@@ -11,7 +11,10 @@ packages:

11flags: {}

13# Extra package databases containing global packages

14+extra-deps:

14−extra-deps: [directory-1.2.7.0]

15+- directory-1.2.7.0

16+- unliftio-core-0.1.1.0

17+- process-1.6.5.1

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

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

17# system-ghc: true

20# system-ghc: true

stack-8.0.yaml+2−1

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

1resolver: lts-7.12

2packages:

3- '.'

4−extra-deps: []

4+extra-deps:

5+- unliftio-core-0.1.1.0

stack-8.6.4.yamlnew file+4

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

1+resolver: lts-13.19

2+packages:

3+- '.'

4+extra-deps: []

stack-8.8.2.yamlnew file+5

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

1+resolver: lts-15.0

2+packages:

3+- '.'

4+extra-deps: []

stack.yaml+1−1

@@ -1 +1 @@

1−stack-8.0.2.yaml

1+stack-8.6.4.yaml

tests/tests.hs+66−6

@@ -2,6 +2,7 @@

3module Main where

5+import Data.Either (rights)

5import Prelude hiding (all)

6import Prelude hiding (all)

6import qualified Test.QuickCheck.Monadic as QCM

7import qualified Test.QuickCheck.Monadic as QCM

7import Test.Tasty

8import Test.Tasty

@@ -14,6 +15,7 @@ import Control.Monad (forM_)

14import Control.Monad.IO.Class

15import Control.Monad.IO.Class

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

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

16import qualified Data.Aeson as JSON

17import qualified Data.Aeson as JSON

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

17import Data.Aeson.Lens (key, _Array, _Null, _Object,

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

18 _String, _Value)

20 _String, _Value)

19import qualified Data.ByteString as B

21import qualified Data.ByteString as B

@@ -22,7 +24,7 @@ import qualified Data.ByteString.Lazy as BL

22import qualified Data.HashMap.Strict as HM

24import qualified Data.HashMap.Strict as HM

23import Data.Int (Int)

25import Data.Int (Int)

24import qualified Data.Map as M

26import qualified Data.Map as M

25−import Data.Maybe (fromJust, isJust)

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

26import Data.Monoid

28import Data.Monoid

27import Data.Text (Text, unpack)

29import Data.Text (Text, unpack)

28import qualified Data.Vector as V

30import qualified Data.Vector as V

@@ -38,6 +40,7 @@ import Docker.Client

39-- opts = defaultClientOpts

41-- opts = defaultClientOpts

40testImageName = "docker-hs/test"

42testImageName = "docker-hs/test"

43+imageToDeleteFullName = "hello-world:latest"

42toStrict1 = B.concat . BL.toChunks

45toStrict1 = B.concat . BL.toChunks

@@ -71,13 +74,27 @@ testFindImage =

71 where

74 where

72 imageFullName = testImageName <> ":latest"

75 imageFullName = testImageName <> ":latest"

77+testDeleteImage :: IO ()

78+testDeleteImage = runDocker $ do

79+ img <- fmap fromJust findTestImage

80+ result <- deleteImage defaultImageDeleteOpts (imageId img)

81+ lift $ assert $ isRight result

82+ maybeTestImageAfter <- findTestImage

83+ lift $ assert $ isNothing maybeTestImageAfter

84+ where

85+ findTestImage =

86+ do

87+ images <- listImages defaultListOpts >>= fromRight

88+ return $ listToMaybe

89+ $ filter (elem imageToDeleteFullName . imageRepoTags) images

90+

74testListContainers :: IO ()

91testListContainers :: IO ()

75testListContainers =

92testListContainers =

76 runDocker $

93 runDocker $

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

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

78 c <- fromRight containerId

95 c <- fromRight containerId

79 res <- listContainers $ ListOpts { all=True }

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

80− deleteContainer (DeleteOpts True True) c

97+ deleteContainer (ContainerDeleteOpts True True) c

81 lift $ assert $ isRight res

98 lift $ assert $ isRight res

83testBuildFromDockerfile :: IO ()

100testBuildFromDockerfile :: IO ()

@@ -88,11 +105,19 @@ testBuildFromDockerfile = do

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

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

89 lift $ assert $ isRight r

106 lift $ assert $ isRight r

107

108+

91testRunAndReadLog :: IO ()

109testRunAndReadLog :: IO ()

92−testRunAndReadLog =

110+testRunAndReadLog = testRunAndReadLogHelper $ NetworkingConfig HM.empty

111+

112+testRunAndReadLogWithNetworking :: IO ()

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

114+

115+testRunAndReadLogHelper :: NetworkingConfig -> IO ()

116+testRunAndReadLogHelper networkingConfig =

93 runDocker $

117 runDocker $

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

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

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

95− containerId <- createContainer (CreateOpts containerConfig defaultHostConfig) Nothing

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

96 c <- fromRight containerId

121 c <- fromRight containerId

97 status1 <- startContainer defaultStartOpts c

122 status1 <- startContainer defaultStartOpts c

98 _ <- inspectContainer c >>= fromRight

123 _ <- inspectContainer c >>= fromRight

@@ -100,11 +125,24 @@ testRunAndReadLog =

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

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

101 logs <- getContainerLogs defaultLogOpts c >>= fromRight

126 logs <- getContainerLogs defaultLogOpts c >>= fromRight

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

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

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

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

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

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

130+ mapM_ removeNetwork createdNetworks

105 where

131 where

106 isRightUnit (Right ()) = True

132 isRightUnit (Right ()) = True

107 isRightUnit _ = False

133 isRightUnit _ = False

134+ networkNames = HM.keys $ endpointsConfig networkingConfig

135+ createNetworkWithName name = createNetwork $

136+ (defaultCreateNetworkOpts name) { createNetworkCheckDuplicate = True }

137+

138+testCreateRemoveNetwork :: IO ()

139+testCreateRemoveNetwork = do

140+ runDocker $ do

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

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

143+ nid <- fromRight createStatus

144+ removeStatus <- removeNetwork nid

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

108

146

109testLogDriverOptionsJson :: TestTree

147testLogDriverOptionsJson :: TestTree

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

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

@@ -184,6 +222,20 @@ testEnvVarJson = testGroup "Testing EnvVar JSON" [testSampleEncode, testSampleDe

184 testCase "Test fromJSON" $ assert $ (JSON.decode "\"cellar=door\"" :: Maybe EnvVar) ==

222 testCase "Test fromJSON" $ assert $ (JSON.decode "\"cellar=door\"" :: Maybe EnvVar) ==

185 Just (EnvVar "cellar" "door")

223 Just (EnvVar "cellar" "door")

186

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+

187integrationTests :: TestTree

239integrationTests :: TestTree

188integrationTests =

240integrationTests =

189 testGroup

241 testGroup

@@ -191,9 +243,12 @@ integrationTests =

191 [ testCase "Get docker version" testDockerVersion

243 [ testCase "Get docker version" testDockerVersion

192 , testCase "Build image from Dockerfile" testBuildFromDockerfile

244 , testCase "Build image from Dockerfile" testBuildFromDockerfile

193 , testCase "Find image by name" testFindImage

245 , testCase "Find image by name" testFindImage

246+ , testCase "Delete image" testDeleteImage

194 , testCase "List containers" testListContainers

247 , testCase "List containers" testListContainers

195 , testCase "Run a dummy container and read its log" testRunAndReadLog

248 , testCase "Run a dummy container and read its log" testRunAndReadLog

249+ , testCase "Run a dummy container with networking and read its log" testRunAndReadLogWithNetworking

196 , testCase "Try to stop a container that doesn't exist" testStopNonexisting

250 , testCase "Try to stop a container that doesn't exist" testStopNonexisting

251+ , testCase "Create and remove a network" testCreateRemoveNetwork

197 ]

252 ]

198

253

199jsonTests :: TestTree

254jsonTests :: TestTree

@@ -206,10 +261,15 @@ jsonTests =

206 , testLogDriverOptionsJson

261 , testLogDriverOptionsJson

207 , testEntrypointJson

262 , testEntrypointJson

208 , testEnvVarJson

263 , testEnvVarJson

264+ , testNetworkingConfigJson

209 ]

265 ]

210

266

211setup :: IO ()

267setup :: IO ()

268+setup =

269+ mapM_ system

270+ [ "docker pull " ++ unpack imageToDeleteFullName

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

271+ , "docker build -t " ++ unpack testImageName ++ " tests"

272+ ]

213

273

214isLeft = not . isRight

274isLeft = not . isRight

215

275