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
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
40 - DOCKER_VERSION="17.05.0~ce-0~ubuntu-trusty" GHCVER=8.0.2
41
41
42+ - DOCKER_VERSION="1.12.3-0~trusty" GHCVER=8.6.4
43+ - DOCKER_VERSION="1.13.1-0~ubuntu-trusty" GHCVER=8.6.4
44+ - DOCKER_VERSION="17.05.0~ce-0~ubuntu-trusty" GHCVER=8.6.4
45+
46+ - DOCKER_VERSION="1.12.3-0~trusty" GHCVER=8.8.2
47+ - DOCKER_VERSION="1.13.1-0~ubuntu-trusty" GHCVER=8.8.2
48+ - DOCKER_VERSION="17.05.0~ce-0~ubuntu-trusty" GHCVER=8.8.2
49+
42addons:
50addons:
43 apt:
51 apt:
44 packages:
52 packages:
CHANGELOG.md+44
@@ -1,5 +1,49 @@
1# CHANGELOG
1# CHANGELOG
2
2
3+## 0.6.0.3 (2020-02-17)
4+
5+- Support for ghc 8.8.2.
6+- Bump dependency version.
7+- Use MonadFail for later versions.
8+
9+## 0.6.0.1 (2019-05-23)
10+
11+- Support ghc 8.6.4.
12+- Bump containers version.
13+
14+## 0.6.0.0 (2018-06-28)
15+
16+- Rename DeleteOpts to ContainerDeleteOpts.
17+- Implement image deletion.
18+- Bump aeson version.
19+- Implement network aliases.
20+- Implement creating/deleting networks.
21+
22+## 0.5.1.1 (2018-03-09)
23+
24+- Bump aeson version.
25+
26+## 0.5.1.0 (2018-02-23)
27+
28+- Support http-conduit-2.3.0.
29+- Bump http-types versions.
30+
31+## 0.5.0.1 (2018-01-26)
32+
33+- Bumps upper bound for http-types (properly this time).
34+
35+## 0.5.0.0 (2018-01-24)
36+
37+- Added (some) contribution and general docs
38+- Fix case when stopping non-existent container
39+- Added more integration tests
40+- Fixed error while parsing list container endpoint output
41+- Changed State/Status data type (related to the above fix)
42+- Added tests against different docker version to travis CIA
43+- Fixed EnvVar JSON encoding
44+- Fixed NetworkMode parsing
45+- Allow http-types 0.11
46+
3## 0.4.1.1 (2017-10-16)
47## 0.4.1.1 (2017-10-16)
4
48
5- Small change to add env var for skipping integration tests.
49- Small change to add env var for skipping integration tests.
docker.cabal+19−8
@@ -1,5 +1,5 @@
1name: docker
1name: docker
2−version: 0.4.1.1
2+version: 0.6.0.3
3synopsis: An API client for docker written in Haskell
3synopsis: An API client for docker written in Haskell
4description: See API documentation below.
4description: See API documentation below.
5homepage: https://github.com/denibertovic/docker-hs
5homepage: https://github.com/denibertovic/docker-hs
@@ -14,25 +14,29 @@ extra-source-files: README.md
14cabal-version: >=1.10
14cabal-version: >=1.10
15stability: experimental
15stability: experimental
16
16
17+-- Flag small-http-conduit
18+-- Description: Resolve whether http-conduit < 2.3.0.
19+-- Manual: False
20+-- Default: True
21+
17library
22library
18 default-extensions: DeriveGeneric, OverloadedStrings, ScopedTypeVariables, ExplicitForAll, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes, DeriveFunctor, FlexibleInstances, CPP
23 default-extensions: DeriveGeneric, OverloadedStrings, ScopedTypeVariables, ExplicitForAll, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes, DeriveFunctor, FlexibleInstances, CPP
19 hs-source-dirs: src
24 hs-source-dirs: src
20 exposed-modules: Docker.Client, Docker.Client.Api, Docker.Client.Types, Docker.Client.Internal, Docker.Client.Http, Docker.Client.Utils
25 exposed-modules: Docker.Client, Docker.Client.Api, Docker.Client.Types, Docker.Client.Internal, Docker.Client.Http, Docker.Client.Utils
21 -- other-modules: Docker.Internal
26 -- other-modules: Docker.Internal
22 build-depends: base >= 4.7 && < 5
27 build-depends: base >= 4.7 && < 5
23− , aeson >= 0.9.0 && < 1.3.0
28+ , aeson >= 0.9.0 && < 2.0.0
24 , blaze-builder >= 0.4.0 && < 0.5.0
29 , blaze-builder >= 0.4.0 && < 0.5.0
25 , bytestring >= 0.10.0 && < 0.11.0
30 , bytestring >= 0.10.0 && < 0.11.0
26− , containers >= 0.5.0 && < 0.6.0
31+ , containers >= 0.5.0 && < 0.7.0
27 , data-default-class >= 0.0.1 && < 0.2.0
32 , data-default-class >= 0.0.1 && < 0.2.0
28− , http-client >= 0.4.0 && < 0.6.0
33+ , http-client >= 0.4.0 && < 0.7.0
29− , http-types >= 0.9 && < 0.11
34+ , http-types >= 0.9 && < 0.13
30 , vector
35 , vector
31 , conduit
36 , conduit
32 , conduit-combinators
37 , conduit-combinators
33 , conduit-extra
38 , conduit-extra
34 , exceptions
39 , exceptions
35− , http-conduit
36 , monad-control
40 , monad-control
37 , resourcet
41 , resourcet
38 , transformers
42 , transformers
@@ -47,13 +51,20 @@ library
47 , mtl >= 2.0.0 && < 3.0.0
51 , mtl >= 2.0.0 && < 3.0.0
48 , network >= 2.6.0
52 , network >= 2.6.0
49 , text >= 1.0.0 && < 2.0.0
53 , text >= 1.0.0 && < 2.0.0
50− , time >= 1.5.0 && < 1.9.0
54+ , time >= 1.5.0 && < 2.0.0
51 , scientific >= 0.3.0 && < 0.4.0
55 , scientific >= 0.3.0 && < 0.4.0
52− , tls >= 1.3.7 && < 1.5.0
56+ , tls >= 1.3.7 && < 1.6.0
53 , unordered-containers >= 0.2.0 && < 0.3.0
57 , unordered-containers >= 0.2.0 && < 0.3.0
54 , x509 >= 1.6.0 && < 1.8.0
58 , x509 >= 1.6.0 && < 1.8.0
55 , x509-store >= 1.6.0 && < 1.8.0
59 , x509-store >= 1.6.0 && < 1.8.0
56 , x509-system >= 1.6.0 && < 1.8.0
60 , x509-system >= 1.6.0 && < 1.8.0
61+ , http-conduit
62+ , unliftio-core >= 0.1.0.0 && < 0.2.0
63+ -- if flag(small-http-conduit)
64+ -- build-depends: http-conduit < 2.3.0
65+ -- else
66+ -- build-depends: http-conduit >= 2.3.0
67+ -- , unliftio-core
57 default-language: Haskell2010
68 default-language: Haskell2010
58 ghc-options: -Wall -fno-warn-name-shadowing
69 ghc-options: -Wall -fno-warn-name-shadowing
59
70
src/Docker/Client/Api.hs+20−2
@@ -18,8 +18,12 @@ module Docker.Client.Api (
18 , getContainerLogsStream
18 , getContainerLogsStream
19 -- * Images
19 -- * Images
20 , listImages
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
92
96
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+33−4
@@ -5,6 +5,9 @@ module Docker.Client.Http where
5
5
6-- import Control.Monad.Base (MonadBase(..), liftBaseDefault)
6-- import Control.Monad.Base (MonadBase(..), liftBaseDefault)
7import Control.Monad.Catch (MonadMask (..))
7import Control.Monad.Catch (MonadMask (..))
8+#if MIN_VERSION_http_conduit(2,3,0)
9+import Control.Monad.IO.Unlift (MonadUnliftIO)
10+#endif
8import Control.Monad.Reader (ReaderT (..), runReaderT)
11import Control.Monad.Reader (ReaderT (..), runReaderT)
9import qualified Data.ByteString.Char8 as BSC
12import qualified Data.ByteString.Char8 as BSC
10import qualified Data.ByteString.Lazy as BL
13import qualified Data.ByteString.Lazy as BL
@@ -104,12 +107,20 @@ mkHttpRequest verb e opts = request
104 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'
107 requestHeaders = [("Content-Type", "application/json; charset=utf-8")]}) $ getEndpointRequestBody e) <$> request'
105 -- Note: Do we need to set length header?
108 -- Note: Do we need to set length header?
106
109
110+defaultHttpHandler :: (
111+#if MIN_VERSION_http_conduit(2,3,0)
112+ MonadUnliftIO m,
113+#endif
107−defaultHttpHandler :: (MonadIO m, MonadMask m) => m (HttpHandler m)
114+ MonadIO m, MonadMask m) => m (HttpHandler m)
108defaultHttpHandler = do
115defaultHttpHandler = do
109 manager <- liftIO $ newManager defaultManagerSettings
116 manager <- liftIO $ newManager defaultManagerSettings
110 return $ httpHandler manager
117 return $ httpHandler manager
111
118
119+httpHandler :: (
120+#if MIN_VERSION_http_conduit(2,3,0)
121+ MonadUnliftIO m,
122+#endif
112−httpHandler :: (MonadIO m, MonadMask m) => HTTP.Manager -> HttpHandler m
123+ MonadIO m, MonadMask m) => HTTP.Manager -> HttpHandler m
113httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..
124httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..
114 let request = NHS.setRequestManager manager request'
125 let request = NHS.setRequestManager manager request'
115 try (NHS.httpSink request sink) >>= \res -> case res of
126 try (NHS.httpSink request sink) >>= \res -> case res of
@@ -127,7 +138,11 @@ httpHandler manager = HttpHandler $ \request' sink -> do -- runResourceT ..
127--
138--
128-- Docker seems to ignore the hostname in requests sent over unix domain
139-- Docker seems to ignore the hostname in requests sent over unix domain
129-- sockets (and the port obviously doesn't matter either)
140-- sockets (and the port obviously doesn't matter either)
141+unixHttpHandler :: (
142+#if MIN_VERSION_http_conduit(2,3,0)
143+ MonadUnliftIO m,
144+#endif
130−unixHttpHandler :: (MonadIO m, MonadMask m) => FilePath -- ^ The socket to connect to
145+ MonadIO m, MonadMask m) => FilePath -- ^ The socket to connect to
131 -> m (HttpHandler m)
146 -> m (HttpHandler m)
132unixHttpHandler fp = do
147unixHttpHandler fp = do
133 let mSettings = defaultManagerSettings
148 let mSettings = defaultManagerSettings
@@ -258,4 +273,18 @@ statusCodeToError (CreateImageEndpoint _ _ _) st =
258 Nothing
273 Nothing
259 else
274 else
260 Just $ DockerInvalidStatusCode st
275 Just $ DockerInvalidStatusCode st
261−
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) =
57getEndpoint v (ContainerLogsEndpoint (LogOpts stdout stderr _ _ _) follow cid) =
58 encodeURLWithQuery [v, "containers", fromContainerID cid, "logs"] query
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))]
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
61 encodeURLWithQuery [v, "containers", fromContainerID cid] query
62 where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))]
62 where query = [("v", Just (encodeQ $ show removeVolumes)), ("force", Just (encodeQ $ show force))]
63getEndpoint v (InspectContainerEndpoint cid) =
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)]
75 where query = [("fromImage", Just n), ("tag", Just t)]
76 n = encodeQ $ T.unpack name
76 n = encodeQ $ T.unpack name
77 t = encodeQ $ T.unpack tag
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]
78
81
79getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody
82getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody
80getEndpointRequestBody VersionEndpoint = Nothing
83getEndpointRequestBody VersionEndpoint = Nothing
@@ -94,6 +97,10 @@ getEndpointRequestBody (InspectContainerEndpoint _) = Nothing
94
97
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
97
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
11 , ImageID
12 , fromImageID
12 , fromImageID
13 , toImageID
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: {}
11flags: {}
12
12
13# Extra package databases containing global packages
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
15
18
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
1resolver: lts-7.12
2packages:
2packages:
3- '.'
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: []
5+
stack.yaml+1−1
@@ -1 +1 @@
1−stack-7.10.yaml
1+stack-8.6.4.yaml
tests/tests.hs+66−6
@@ -2,6 +2,7 @@
2
2
3module Main where
3module Main where
4
4
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
38
40
39-- opts = defaultClientOpts
41-- opts = defaultClientOpts
40testImageName = "docker-hs/test"
42testImageName = "docker-hs/test"
43+imageToDeleteFullName = "hello-world:latest"
41
44
42toStrict1 = B.concat . BL.toChunks
45toStrict1 = B.concat . BL.toChunks
43
46
@@ -71,13 +74,27 @@ testFindImage =
71 where
74 where
72 imageFullName = testImageName <> ":latest"
75 imageFullName = testImageName <> ":latest"
73
76
77+testDeleteImage :: IO ()
78+testDeleteImage = runDocker $ do
79+ img <- fmap fromJust findTestImage
80+ result <- deleteImage defaultImageDeleteOpts (imageId img)
81+ lift $ assert $ isRight result
82+ maybeTestImageAfter <- findTestImage
83+ lift $ assert $ isNothing maybeTestImageAfter
84+ where
85+ findTestImage =
86+ do
87+ images <- listImages defaultListOpts >>= fromRight
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
82
99
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
90
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