926a5cb · docker-hs · git.iko.soy

git.iko.soy/docker-hs

on master help sign in

Add connectNetwork endpoint

926a5cbBen Hamlin7 years ago

src/Docker/Client/Api.hs+5

compare with master

unifiedsplit

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

26 , removeNetwork

27 , listNetworks

28 , inspectNetwork

29+ , connectNetwork

29 -- * Other

30 -- * Other

30 , getDockerVersion

31 , getDockerVersion

31 ) where

32 ) where

@@ -234,3 +235,7 @@ listNetworks nfs = requestHelper GET (ListNetworksEndpoint nfs) >>= parseRespons

234-- | Gets 'NetworkDetails' for a network, given its name or id.

235-- | Gets 'NetworkDetails' for a network, given its name or id.

235inspectNetwork :: forall m . (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError NetworkDetails)

236inspectNetwork :: forall m . (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError NetworkDetails)

236inspectNetwork nid = requestHelper GET (InspectNetworkEndpoint nid) >>= parseResponse

237inspectNetwork nid = requestHelper GET (InspectNetworkEndpoint nid) >>= parseResponse

238+

239+-- | Connects a container to a network.

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

241+connectNetwork nid cfg = requestUnit POST $ ConnectNetworkEndpoint nid cfg

src/Docker/Client/Http.hs+5

@@ -298,3 +298,8 @@ statusCodeToError (InspectNetworkEndpoint _) st =

298 Nothing

299 else

300 Just $ DockerInvalidStatusCode st

301+statusCodeToError (ConnectNetworkEndpoint _ _) st =

302+ if st == status200 then

303+ Nothing

304+ else

305+ Just $ DockerInvalidStatusCode st

src/Docker/Client/Internal.hs+2

@@ -81,6 +81,7 @@ getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"]

81getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid]

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

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

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

85getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

86getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

86getEndpointRequestBody VersionEndpoint = Nothing

87getEndpointRequestBody VersionEndpoint = Nothing

@@ -106,6 +107,7 @@ getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS

106getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing

107getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing

107getEndpointRequestBody (ListNetworksEndpoint _) = Nothing

108getEndpointRequestBody (ListNetworksEndpoint _) = Nothing

108getEndpointRequestBody (InspectNetworkEndpoint _) = Nothing

109getEndpointRequestBody (InspectNetworkEndpoint _) = Nothing

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

109

111

110getEndpointContentType :: Endpoint -> BSC.ByteString

112getEndpointContentType :: Endpoint -> BSC.ByteString

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

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

src/Docker/Client/Types.hs+51

@@ -86,6 +86,12 @@ module Docker.Client.Types (

86 , NetworkType(..)

87 , NetworkName

88 , NetworkFilter(..)

89+ , ConnectConfig(..)

90+ , defaultConnectConfig

91+ , EndpointSettings(..)

92+ , defaultEndpointSettings

93+ , IPAMSettings(..)

94+ , defaultIPAMSettings

89 , EndpointConfig(..)

95 , EndpointConfig(..)

90 , Ulimit(..)

96 , Ulimit(..)

91 , ContainerResources(..)

97 , ContainerResources(..)

@@ -152,6 +158,7 @@ data Endpoint =

152 | RemoveNetworkEndpoint NetworkID

158 | RemoveNetworkEndpoint NetworkID

153 | ListNetworksEndpoint [NetworkFilter]

159 | ListNetworksEndpoint [NetworkFilter]

154 | InspectNetworkEndpoint NetworkID

160 | InspectNetworkEndpoint NetworkID

161+ | ConnectNetworkEndpoint NetworkID ConnectConfig

155 deriving (Eq, Show)

162 deriving (Eq, Show)

156

163

157-- | We should newtype this

164-- | We should newtype this

@@ -1019,6 +1026,50 @@ instance {-# OVERLAPPING #-} ToJSON [NetworkFilter] where

1019 toKV (NetworkFilterScope s) = "scope" .= [fromNetworkScope s]

1026 toKV (NetworkFilterScope s) = "scope" .= [fromNetworkScope s]

1020 toKV (NetworkFilterType t) = "type" .= [fromNetworkType t]

1027 toKV (NetworkFilterType t) = "type" .= [fromNetworkType t]

1021

1028

1029+data ConnectConfig = ConnectConfig

1030+ { connectContainer :: Text

1031+ , connectEndpointConfig :: EndpointSettings

1032+ } deriving (Eq, Show, Generic)

1033+

1034+instance ToJSON ConnectConfig where

1035+ toJSON = genericToJSON defaultOptions { fieldLabelModifier = drop 7 }

1036+

1037+defaultConnectConfig :: Text -> ConnectConfig

1038+defaultConnectConfig = flip ConnectConfig defaultEndpointSettings

1039+

1040+data EndpointSettings = EndpointSettings

1041+ { endpointIPAMConfig :: IPAMSettings

1042+ , endpointLinks :: [Text]

1043+ , endpointAliases :: [Text]

1044+ , endpointNetworkID :: Maybe Text

1045+ , endpointEndpointID :: Maybe Text

1046+ , endpointGateway :: Maybe Text

1047+ , endpointIPAddress :: Maybe Text

1048+ , endpointIPPrefixLen :: Maybe Int

1049+ , endpointIPv6Gateway :: Maybe Text

1050+ , endpointGlobalIPv6Address :: Maybe Text

1051+ , endpointGlobalIPv6PrefixLen :: Maybe Int

1052+ , endpointMacAddress :: Maybe Text

1053+ } deriving (Eq, Show, Generic)

1054+

1055+instance ToJSON EndpointSettings where

1056+ toJSON = genericToJSON defaultOptions { fieldLabelModifier = drop 8 }

1057+

1058+defaultEndpointSettings :: EndpointSettings

1059+defaultEndpointSettings = EndpointSettings defaultIPAMSettings [] [] Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing

1060+

1061+data IPAMSettings = IPAMSettings

1062+ { ipamIPv4Address :: Maybe Text

1063+ , ipamIPv6Address :: Maybe Text

1064+ , ipamLinkLocalIPs :: [Text]

1065+ } deriving (Eq, Show, Generic)

1066+

1067+instance ToJSON IPAMSettings where

1068+ toJSON = genericToJSON defaultOptions { fieldLabelModifier = drop 4 }

1069+

1070+defaultIPAMSettings :: IPAMSettings

1071+defaultIPAMSettings = IPAMSettings Nothing Nothing []

1072+

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

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

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

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

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

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

tests/tests.hs+17−1

@@ -156,8 +156,22 @@ testInspectNetwork :: IO ()

156testInspectNetwork =

157 runDocker $ do

158 res <- inspectNetwork . fromJust $ toNetworkID "bridge"

159− lift $ assertBool ("inspecting networks, unewxpected status: " ++ show res) $ isRight res

159+ lift $ assertBool ("inspecting networks, unexpected status: " ++ show res) $ isRight res

160

161+testConnectNetwork :: IO ()

162+testConnectNetwork =

163+ runDocker $ do

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

165+ networkId <- fromRight =<< createNetwork (defaultCreateNetworkOpts "mynetwork")

166+ res <- connectNetwork networkId . defaultConnectConfig $ fromContainerID containerId

167+ lift $ assertBool ("connecting network, unexpected status: " ++ show res) $ isRight res

168+ details <- fromRight =<< inspectContainer containerId

169+ _ <- deleteContainer defaultContainerDeleteOpts containerId

170+ _ <- removeNetwork networkId

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

172+ lift $ assertBool "connecting network failed" $ NetworkNamed "mynetwork" `elem` networks

173+ where

174+ networkMode (Network mode _) = mode

161

175

162testLogDriverOptionsJson :: TestTree

176testLogDriverOptionsJson :: TestTree

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

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

@@ -265,6 +279,8 @@ integrationTests =

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

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

266 , testCase "Create and remove a network" testCreateRemoveNetwork

280 , testCase "Create and remove a network" testCreateRemoveNetwork

267 , testCase "List networks" testListNetworks

281 , testCase "List networks" testListNetworks

282+ , testCase "Inspect a network" testInspectNetwork

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

268 ]

284 ]

269

285

270jsonTests :: TestTree

286jsonTests :: TestTree