1147188 · docker-hs · git.iko.soy

src/Docker/Client/Api.hs+5

compare with master

unifiedsplit

@@ -27,6 +27,7 @@ module Docker.Client.Api (

27 , listNetworks

28 , inspectNetwork

29 , connectNetwork

30+ , disconnectNetwork

30 -- * Other

31 -- * Other

31 , getDockerVersion

32 , getDockerVersion

32 ) where

33 ) where

@@ -239,3 +240,7 @@ inspectNetwork nid = requestHelper GET (InspectNetworkEndpoint nid) >>= parseRes

239-- | Connects a container to a network.

240-- | Connects a container to a network.

240connectNetwork :: forall m . (MonadIO m, MonadMask m) => NetworkID -> ConnectConfig -> DockerT m (Either DockerError ())

241connectNetwork :: forall m . (MonadIO m, MonadMask m) => NetworkID -> ConnectConfig -> DockerT m (Either DockerError ())

241connectNetwork nid cfg = requestUnit POST $ ConnectNetworkEndpoint nid cfg

242connectNetwork nid cfg = requestUnit POST $ ConnectNetworkEndpoint nid cfg

243+

244+-- | Disconnects a container from a network.

245+disconnectNetwork :: forall m . (MonadIO m, MonadMask m) => NetworkID -> DisconnectConfig -> DockerT m (Either DockerError ())

246+disconnectNetwork nid cfg = requestUnit POST $ DisconnectNetworkEndpoint nid cfg

src/Docker/Client/Http.hs+5

@@ -303,3 +303,8 @@ statusCodeToError (ConnectNetworkEndpoint _ _) st =

303 Nothing

304 else

305 Just $ DockerInvalidStatusCode st

306+statusCodeToError (DisconnectNetworkEndpoint _ _) st =

307+ if st == status200 then

308+ Nothing

309+ else

310+ Just $ DockerInvalidStatusCode st

src/Docker/Client/Internal.hs+2

@@ -82,6 +82,7 @@ getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetwor

82getEndpoint v (ListNetworksEndpoint nfs) = encodeURLWithQuery [v, "networks"] [("filters", Just . BSLC.toStrict $ JSON.encode nfs)]

83getEndpoint v (InspectNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid]

84getEndpoint v (ConnectNetworkEndpoint nid _) = encodeURL [v, "networks", fromNetworkID nid, "connect"]

85+getEndpoint v (DisconnectNetworkEndpoint nid _) = encodeURL [v, "networks", fromNetworkID nid, "disconnect"]

85

86

86getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

87getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

87getEndpointRequestBody VersionEndpoint = Nothing

88getEndpointRequestBody VersionEndpoint = Nothing

@@ -108,6 +109,7 @@ getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing

108getEndpointRequestBody (ListNetworksEndpoint _) = Nothing

109getEndpointRequestBody (ListNetworksEndpoint _) = Nothing

109getEndpointRequestBody (InspectNetworkEndpoint _) = Nothing

110getEndpointRequestBody (InspectNetworkEndpoint _) = Nothing

110getEndpointRequestBody (ConnectNetworkEndpoint _ cfg) = Just $ HTTP.RequestBodyLBS (JSON.encode cfg)

111getEndpointRequestBody (ConnectNetworkEndpoint _ cfg) = Just $ HTTP.RequestBodyLBS (JSON.encode cfg)

112+getEndpointRequestBody (DisconnectNetworkEndpoint _ cfg) = Just $ HTTP.RequestBodyLBS (JSON.encode cfg)

111

113

112getEndpointContentType :: Endpoint -> BSC.ByteString

114getEndpointContentType :: Endpoint -> BSC.ByteString

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

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

src/Docker/Client/Types.hs+14

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

88 , NetworkFilter(..)

89 , ConnectConfig(..)

90 , defaultConnectConfig

91+ , DisconnectConfig(..)

92+ , defaultDisconnectConfig

91 , EndpointSettings(..)

93 , EndpointSettings(..)

92 , defaultEndpointSettings

94 , defaultEndpointSettings

93 , IPAMSettings(..)

95 , IPAMSettings(..)

@@ -159,6 +161,7 @@ data Endpoint =

159 | ListNetworksEndpoint [NetworkFilter]

161 | ListNetworksEndpoint [NetworkFilter]

160 | InspectNetworkEndpoint NetworkID

162 | InspectNetworkEndpoint NetworkID

161 | ConnectNetworkEndpoint NetworkID ConnectConfig

163 | ConnectNetworkEndpoint NetworkID ConnectConfig

164+ | DisconnectNetworkEndpoint NetworkID DisconnectConfig

162 deriving (Eq, Show)

165 deriving (Eq, Show)

163

166

164-- | We should newtype this

167-- | We should newtype this

@@ -1037,6 +1040,17 @@ instance ToJSON ConnectConfig where

1037defaultConnectConfig :: Text -> ConnectConfig

1040defaultConnectConfig :: Text -> ConnectConfig

1038defaultConnectConfig = flip ConnectConfig defaultEndpointSettings

1041defaultConnectConfig = flip ConnectConfig defaultEndpointSettings

1039

1042

1043+data DisconnectConfig = DisconnectConfig

1044+ { disconnectContainer :: Text

1045+ , disconnectForce :: Bool

1046+ } deriving (Eq, Show, Generic)

1047+

1048+instance ToJSON DisconnectConfig where

1049+ toJSON = genericToJSON defaultOptions { fieldLabelModifier = drop 10 }

1050+

1051+defaultDisconnectConfig :: Text -> DisconnectConfig

1052+defaultDisconnectConfig = flip DisconnectConfig False

1053+

1040data EndpointSettings = EndpointSettings

1054data EndpointSettings = EndpointSettings

1041 { endpointIPAMConfig :: IPAMSettings

1055 { endpointIPAMConfig :: IPAMSettings

1042 , endpointLinks :: [Text]

1056 , endpointLinks :: [Text]

tests/tests.hs+26

@@ -173,6 +173,19 @@ testConnectNetwork =

173 where

174 networkMode (Network mode _) = mode

175

176+testDisconnectNetwork :: IO ()

177+testDisconnectNetwork =

178+ runDocker $ do

179+ containerId <- fromRight =<< createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing

180+ res <- disconnectNetwork (fromJust $ toNetworkID "bridge") (defaultDisconnectConfig $ fromContainerID containerId)

181+ lift $ assertBool ("disconnecting network, unexpected status: " ++ show res) $ isRight res

182+ details <- fromRight =<< inspectContainer containerId

183+ _ <- deleteContainer defaultContainerDeleteOpts containerId

184+ let networks = networkMode <$> (networkSettingsNetworks . networkSettings) details

185+ lift $ assertBool "disconnecting network failed" $ null networks

186+ where

187+ networkMode (Network mode _) = mode

188+

176testLogDriverOptionsJson :: TestTree

189testLogDriverOptionsJson :: TestTree

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

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

178 where

191 where

@@ -265,6 +278,17 @@ testNetworkingConfigJson = testGroup "Testing NetworkingConfig JSON" [testSample

265 ]

278 ]

266 ]

279 ]

267

280

281+testDisconnectConfigJson :: TestTree

282+testDisconnectConfigJson = testGroup "Testing DisconnectConfig JSON" [testSampleEncode]

283+ where

284+ testSampleEncode =

285+ let config = DisconnectConfig "mycontainer" True

286+ in testCase "Test toJSON" $ assert $ JSON.toJSON config ==

287+ JSON.object

288+ [ "Container" .= ("mycontainer" :: Text)

289+ , "Force" .= True

290+ ]

291+

268integrationTests :: TestTree

292integrationTests :: TestTree

269integrationTests =

293integrationTests =

270 testGroup

294 testGroup

@@ -281,6 +305,7 @@ integrationTests =

281 , testCase "List networks" testListNetworks

305 , testCase "List networks" testListNetworks

282 , testCase "Inspect a network" testInspectNetwork

306 , testCase "Inspect a network" testInspectNetwork

283 , testCase "Connect a container to a network" testConnectNetwork

307 , testCase "Connect a container to a network" testConnectNetwork

308+ , testCase "Disconnect a container from a network" testDisconnectNetwork

284 ]

309 ]

285

310

286jsonTests :: TestTree

311jsonTests :: TestTree

@@ -294,6 +319,7 @@ jsonTests =

294 , testEntrypointJson

319 , testEntrypointJson

295 , testEnvVarJson

320 , testEnvVarJson

296 , testNetworkingConfigJson

321 , testNetworkingConfigJson

322+ , testDisconnectConfigJson

297 ]

323 ]

298

324

299setup :: IO ()

325setup :: IO ()