master..60cc72f · docker-hs

git.iko.soy/docker-hs

on 60cc72f help sign in

.travis.yml−8

since splitsnapshots

unifiedsplit

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

50addons:

42addons:

51 apt:

43 apt:

52 packages:

44 packages:

CHANGELOG.md−19

@@ -1,24 +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)

3## 0.5.1.1 (2018-03-09)

24- Bump aeson version.

5- Bump aeson version.

docker.cabal+6−6

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

1name: docker

2−version: 0.6.0.3

2+version: 0.5.1.1

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 && < 2.0.0

28+ , aeson >= 0.9.0 && < 1.4.0

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

30 , bytestring >= 0.10.0 && < 0.11.0

31− , containers >= 0.5.0 && < 0.7.0

31+ , containers >= 0.5.0 && < 0.6.0

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

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

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

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

35 , vector

36 , conduit

@@ -51,9 +51,9 @@ 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 && < 2.0.0

54+ , time >= 1.5.0 && < 1.9.0

55 , scientific >= 0.3.0 && < 0.4.0

56− , tls >= 1.3.7 && < 1.6.0

56+ , tls >= 1.3.7 && < 1.5.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

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

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

18 , getContainerLogsStream

19 -- * Images

20 , listImages

21− , deleteImage

22 , buildImageFromDockerfile

21 , buildImageFromDockerfile

23 , pullImage

22 , pullImage

24− -- * Network

25− , createNetwork

26− , removeNetwork

27 -- * Other

23 -- * Other

28 , getDockerVersion

24 , getDockerVersion

29 ) where

25 ) where

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

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

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

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

91listImages 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

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

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

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

105-- for some sane defaults.

95-- for some sane defaults.

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

145unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid

135unpauseContainer cid = requestUnit GET $ UnpauseContainerEndpoint cid

146

136

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

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

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

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

149-- defaults.

139-- defaults.

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

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

151deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid

141deleteContainer dopts cid = requestUnit DELETE $ DeleteContainerEndpoint dopts cid

152

142

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

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

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

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

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

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

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

219

209

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

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

273 Nothing

274 else

275 Just $ DockerInvalidStatusCode st

276−statusCodeToError (DeleteImageEndpoint _ _) st =

276+

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

@@ -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 (ContainerDeleteOpts removeVolumes force) cid) =

60+getEndpoint v (DeleteContainerEndpoint (DeleteOpts 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,9 +75,6 @@ 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]

82getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

79getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

83getEndpointRequestBody VersionEndpoint = Nothing

80getEndpointRequestBody VersionEndpoint = Nothing

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

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

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

99getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing

96getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing

100−getEndpointRequestBody (DeleteImageEndpoint _ _) = Nothing

101−

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

103−getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing

104

105getEndpointContentType :: Endpoint -> BSC.ByteString

98getEndpointContentType :: Endpoint -> BSC.ByteString

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

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

src/Docker/Client/Types.hs+14−86

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

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

40 , DetachKeys(..)

37 , DetachKeys(..)

41 , StartOpts(..)

38 , StartOpts(..)

42 , defaultStartOpts

39 , defaultStartOpts

43− , ContainerDeleteOpts(..)

40+ , DeleteOpts(..)

44− , defaultContainerDeleteOpts

41+ , defaultDeleteOpts

45− , ImageDeleteOpts(..)

46− , defaultImageDeleteOpts

47 , Timestamp

42 , Timestamp

48 , TailLogOpt(..)

43 , TailLogOpt(..)

49 , LogOpts(..)

44 , LogOpts(..)

50 , defaultLogOpts

45 , defaultLogOpts

51− , CreateNetworkOpts(..)

52− , defaultCreateNetworkOpts

53 , VolumePermission(..)

46 , VolumePermission(..)

54 , Bind(..)

47 , Bind(..)

55 , Volume(..)

48 , Volume(..)

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

132 | UnpauseContainerEndpoint ContainerID

125 | UnpauseContainerEndpoint ContainerID

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

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

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

135− | DeleteContainerEndpoint ContainerDeleteOpts ContainerID

128+ | DeleteContainerEndpoint DeleteOpts ContainerID

136 | InspectContainerEndpoint ContainerID

129 | InspectContainerEndpoint ContainerID

137 | BuildImageEndpoint BuildOpts FilePath

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

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

132 deriving (Eq, Show)

143

133

144-- | We should newtype this

134-- | We should newtype this

@@ -634,12 +624,9 @@ instance ToJSON EndpointConfig where

634 [ "Aliases" .= aliases

624 [ "Aliases" .= aliases

635 ]

625 ]

636

626

637−-- | Alias for endpoint name

638−type EndpointName = Text

639−

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

627-- | Data type for the NetworkingConfig section of the container settings

641newtype NetworkingConfig = NetworkingConfig

628newtype NetworkingConfig = NetworkingConfig

642− { endpointsConfig :: HM.HashMap EndpointName EndpointConfig

629+ { endpointsConfig :: HM.HashMap Text EndpointConfig

643 } deriving (Eq, Show)

630 } deriving (Eq, Show)

644

631

645instance ToJSON NetworkingConfig where

632instance ToJSON NetworkingConfig where

@@ -649,9 +636,9 @@ instance ToJSON NetworkingConfig where

649

636

650-- | Options used for creating a Container.

637-- | Options used for creating a Container.

651data CreateOpts = CreateOpts {

638data CreateOpts = CreateOpts {

652− containerConfig :: ContainerConfig

639+ containerConfig :: ContainerConfig

653− , hostConfig :: HostConfig

640+ , hostConfig :: HostConfig

654− , networkingConfig :: NetworkingConfig

641+ , networkingConfig :: Maybe NetworkingConfig

655 } deriving (Eq, Show)

642 } deriving (Eq, Show)

656

643

657instance ToJSON CreateOpts where

644instance ToJSON CreateOpts where

@@ -661,7 +648,9 @@ instance ToJSON CreateOpts where

661 case ccJSON of

648 case ccJSON of

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

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

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

650 let o1 = HM.insert "HostConfig" hcJSON o

651+ let o2 = case nc of

652+ Nothing -> o1

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

653+ Just _ -> HM.insert "NetworkingConfig" (toJSON nc) o1

665 JSON.Object o2

654 JSON.Object o2

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

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

667

656

@@ -747,7 +736,7 @@ defaultCreateOpts :: T.Text -> CreateOpts

747defaultCreateOpts imageName = CreateOpts

736defaultCreateOpts imageName = CreateOpts

748 { containerConfig = defaultContainerConfig imageName

737 { containerConfig = defaultContainerConfig imageName

749 , hostConfig = defaultHostConfig

738 , hostConfig = defaultHostConfig

750− , networkingConfig = NetworkingConfig HM.empty

739+ , networkingConfig = Nothing

751 }

740 }

752

741

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

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

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

762defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }

751defaultStartOpts = StartOpts { detachKeys = DefaultDetachKey }

763

752

764-- | Options for deleting a container.

753-- | Options for deleting a container.

765−data ContainerDeleteOpts = ContainerDeleteOpts {

754+data DeleteOpts = DeleteOpts {

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

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

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

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

768 } deriving (Eq, Show)

757 } deriving (Eq, Show)

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

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

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

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

794-- running.

783-- running.

795−defaultContainerDeleteOpts :: ContainerDeleteOpts

784+defaultDeleteOpts :: DeleteOpts

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

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

786

805-- | Timestamp alias.

787-- | Timestamp alias.

806type Timestamp = Integer

788type Timestamp = Integer

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

828 , tail = All

810 , tail = All

829 }

811 }

830

812

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

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

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

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

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

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

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

1033 toJSON NetworkDisabled = JSON.String "none"

985 toJSON NetworkDisabled = JSON.String "none"

1034 toJSON (NetworkNamed n) = JSON.String n

986 toJSON (NetworkNamed n) = JSON.String n

1035

987

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−

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

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

1057

989

1058instance Show PortType where

990instance Show PortType where

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

1564 macAddress labels stopSignal

1496 macAddress labels stopSignal

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

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

1566

1498

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

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

1569−#else

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

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

1571−#endif

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

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

1573 Nothing ->

1501 Nothing ->

1574 fail "Could not parse Integer"

1502 fail "Could not parse Integer"

stack-7.10.yaml−1

@@ -14,7 +14,6 @@ flags: {}

14extra-deps:

15- directory-1.2.7.0

16- unliftio-core-0.1.1.0

17−- process-1.6.5.1

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

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

20# system-ghc: true

19# system-ghc: true

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-8.0.2.yaml

tests/tests.hs+6−50

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

3module Main where

5−import Data.Either (rights)

6import Prelude hiding (all)

5import Prelude hiding (all)

7import qualified Test.QuickCheck.Monadic as QCM

6import qualified Test.QuickCheck.Monadic as QCM

8import Test.Tasty

7import Test.Tasty

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

24import qualified Data.HashMap.Strict as HM

23import qualified Data.HashMap.Strict as HM

25import Data.Int (Int)

24import Data.Int (Int)

26import qualified Data.Map as M

25import qualified Data.Map as M

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

26+import Data.Maybe (fromJust, isJust)

28import Data.Monoid

27import Data.Monoid

29import Data.Text (Text, unpack)

28import Data.Text (Text, unpack)

30import qualified Data.Vector as V

29import qualified Data.Vector as V

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

41-- opts = defaultClientOpts

40-- opts = defaultClientOpts

42testImageName = "docker-hs/test"

41testImageName = "docker-hs/test"

43−imageToDeleteFullName = "hello-world:latest"

45toStrict1 = B.concat . BL.toChunks

43toStrict1 = B.concat . BL.toChunks

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

74 where

72 where

75 imageFullName = testImageName <> ":latest"

73 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−

91testListContainers :: IO ()

75testListContainers :: IO ()

92testListContainers =

76testListContainers =

93 runDocker $

77 runDocker $

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

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

95 c <- fromRight containerId

79 c <- fromRight containerId

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

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

97− deleteContainer (ContainerDeleteOpts True True) c

81+ deleteContainer (DeleteOpts True True) c

98 lift $ assert $ isRight res

82 lift $ assert $ isRight res

100testBuildFromDockerfile :: IO ()

84testBuildFromDockerfile :: IO ()

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

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

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

106 lift $ assert $ isRight r

90 lift $ assert $ isRight r

107

108−

109testRunAndReadLog :: IO ()

92testRunAndReadLog :: IO ()

110−testRunAndReadLog = testRunAndReadLogHelper $ NetworkingConfig HM.empty

93+testRunAndReadLog =

111−

112−testRunAndReadLogWithNetworking :: IO ()

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

114−

115−testRunAndReadLogHelper :: NetworkingConfig -> IO ()

116−testRunAndReadLogHelper networkingConfig =

117 runDocker $

94 runDocker $

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

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

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

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

96+ containerId <- createContainer (CreateOpts containerConfig defaultHostConfig Nothing) Nothing

121 c <- fromRight containerId

97 c <- fromRight containerId

122 status1 <- startContainer defaultStartOpts c

98 status1 <- startContainer defaultStartOpts c

123 _ <- inspectContainer c >>= fromRight

99 _ <- inspectContainer c >>= fromRight

@@ -125,24 +101,11 @@ testRunAndReadLogHelper networkingConfig =

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

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

126 logs <- getContainerLogs defaultLogOpts c >>= fromRight

102 logs <- getContainerLogs defaultLogOpts c >>= fromRight

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

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

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

104+ status3 <- deleteContainer (DeleteOpts True True) c

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

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

130− mapM_ removeNetwork createdNetworks

131 where

106 where

132 isRightUnit (Right ()) = True

107 isRightUnit (Right ()) = True

133 isRightUnit _ = False

108 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

109

147testLogDriverOptionsJson :: TestTree

110testLogDriverOptionsJson :: TestTree

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

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

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

243 [ testCase "Get docker version" testDockerVersion

206 [ testCase "Get docker version" testDockerVersion

244 , testCase "Build image from Dockerfile" testBuildFromDockerfile

207 , testCase "Build image from Dockerfile" testBuildFromDockerfile

245 , testCase "Find image by name" testFindImage

208 , testCase "Find image by name" testFindImage

246− , testCase "Delete image" testDeleteImage

247 , testCase "List containers" testListContainers

209 , testCase "List containers" testListContainers

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

210 , 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

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

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

252 ]

212 ]

253

213

254jsonTests :: TestTree

214jsonTests :: TestTree

@@ -265,11 +225,7 @@ jsonTests =

265 ]

225 ]

266

226

267setup :: IO ()

227setup :: IO ()

268−setup =

269− mapM_ system

270− [ "docker pull " ++ unpack imageToDeleteFullName

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

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

272− ]

273

229

274isLeft = not . isRight

230isLeft = not . isRight

275

231