git.iko.soy/docker-hs
on master help sign in
Add connectNetwork endpoint
commit926a5cb5bf285829b59f29e8a4a498c15681722d authorBen Hamlin <protob3n@gmail.com> dateThu 4 Jul 2019, 15:25 (7 years ago) parent78e5ae2
5 files changed+80−1
compare with master
unifiedsplit
src/Docker/Client/Api.hs+5 src/Docker/Client/Http.hs+5 src/Docker/Client/Internal.hs+2 src/Docker/Client/Types.hs+51 tests/tests.hs+17−1
src/Docker/Client/Api.hs+5
@@ -26,6 +26,7 @@ module Docker.Client.Api (
2626 , removeNetwork
2727 , listNetworks
2828 , inspectNetwork
29+ , connectNetwork
2930 -- * Other
3031 , getDockerVersion
3132 ) where
@@ -234,3 +235,7 @@ listNetworks nfs = requestHelper GET (ListNetworksEndpoint nfs) >>= parseRespons
234235-- | Gets 'NetworkDetails' for a network, given its name or id.
235236inspectNetwork :: forall m . (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError NetworkDetails)
236237inspectNetwork 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 =
298298 Nothing
299299 else
300300 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"]
8181getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid]
8282getEndpoint v (ListNetworksEndpoint nfs) = encodeURLWithQuery [v, "networks"] [("filters", Just . BSLC.toStrict $ JSON.encode nfs)]
8383getEndpoint v (InspectNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid]
84+getEndpoint v (ConnectNetworkEndpoint nid _) = encodeURL [v, "networks", fromNetworkID nid, "connect"]
8485
8586getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody
8687getEndpointRequestBody VersionEndpoint = Nothing
@@ -106,6 +107,7 @@ getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS
106107getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing
107108getEndpointRequestBody (ListNetworksEndpoint _) = Nothing
108109getEndpointRequestBody (InspectNetworkEndpoint _) = Nothing
110+getEndpointRequestBody (ConnectNetworkEndpoint _ cfg) = Just $ HTTP.RequestBodyLBS (JSON.encode cfg)
109111
110112getEndpointContentType :: Endpoint -> BSC.ByteString
111113getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar"
src/Docker/Client/Types.hs+51
@@ -86,6 +86,12 @@ module Docker.Client.Types (
8686 , NetworkType(..)
8787 , NetworkName
8888 , NetworkFilter(..)
89+ , ConnectConfig(..)
90+ , defaultConnectConfig
91+ , EndpointSettings(..)
92+ , defaultEndpointSettings
93+ , IPAMSettings(..)
94+ , defaultIPAMSettings
8995 , EndpointConfig(..)
9096 , Ulimit(..)
9197 , ContainerResources(..)
@@ -152,6 +158,7 @@ data Endpoint =
152158 | RemoveNetworkEndpoint NetworkID
153159 | ListNetworksEndpoint [NetworkFilter]
154160 | InspectNetworkEndpoint NetworkID
161+ | ConnectNetworkEndpoint NetworkID ConnectConfig
155162 deriving (Eq, Show)
156163
157164-- | We should newtype this
@@ -1019,6 +1026,50 @@ instance {-# OVERLAPPING #-} ToJSON [NetworkFilter] where
10191026 toKV (NetworkFilterScope s) = "scope" .= [fromNetworkScope s]
10201027 toKV (NetworkFilterType t) = "type" .= [fromNetworkType t]
10211028
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+
10221073-- TOOD: Add support for SELinux Volume labels (eg. "ro,z" or "ro/Z")
10231074-- | Set permissions on volumes that you mount in the container.
10241075data VolumePermission = ReadWrite | ReadOnly deriving (Eq, Show, Generic)
tests/tests.hs+17−1
@@ -156,8 +156,22 @@ testInspectNetwork :: IO ()
156156testInspectNetwork =
157157 runDocker $ do
158158 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
160160
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
161175
162176testLogDriverOptionsJson :: TestTree
163177testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [test1, test2, test3]
@@ -265,6 +279,8 @@ integrationTests =
265279 , testCase "Try to stop a container that doesn't exist" testStopNonexisting
266280 , testCase "Create and remove a network" testCreateRemoveNetwork
267281 , testCase "List networks" testListNetworks
282+ , testCase "Inspect a network" testInspectNetwork
283+ , testCase "Connect a container to a network" testConnectNetwork
268284 ]
269285
270286jsonTests :: TestTree