From 5406510ff3181232f748281c6038b4d81ac9d703 Mon Sep 17 00:00:00 2001 From: Ben Hamlin Date: Tue, 2 Jul 2019 17:49:17 -0500 Subject: [PATCH 1/7] Add listNetworks endpoint --- src/Docker/Client/Api.hs | 4 + src/Docker/Client/Http.hs | 5 + src/Docker/Client/Internal.hs | 27 +++--- src/Docker/Client/Types.hs | 169 +++++++++++++++++++++++++++++++++- tests/tests.hs | 9 ++ 5 files changed, 198 insertions(+), 16 deletions(-) diff --git a/src/Docker/Client/Api.hs b/src/Docker/Client/Api.hs index 8d7c32b..1749347 100644 --- a/src/Docker/Client/Api.hs +++ b/src/Docker/Client/Api.hs @@ -24,6 +24,7 @@ module Docker.Client.Api ( -- * Network , createNetwork , removeNetwork + , listNetworks -- * Other , getDockerVersion ) where @@ -225,3 +226,6 @@ createNetwork opts = requestHelper POST (CreateNetworkEndpoint opts) >>= parseR removeNetwork :: forall m. (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError ()) removeNetwork nid = requestUnit DELETE $ RemoveNetworkEndpoint nid +-- | Lists networks optionally matching a list of 'Filter's +listNetworks :: forall m . (MonadIO m, MonadMask m) => [NetworkFilter] -> DockerT m (Either DockerError [NetworkDetails]) +listNetworks nfs = requestHelper GET (ListNetworksEndpoint nfs) >>= parseResponse diff --git a/src/Docker/Client/Http.hs b/src/Docker/Client/Http.hs index 5a2bb49..9675ed2 100644 --- a/src/Docker/Client/Http.hs +++ b/src/Docker/Client/Http.hs @@ -288,3 +288,8 @@ statusCodeToError (RemoveNetworkEndpoint _) st = Nothing else Just $ DockerInvalidStatusCode st +statusCodeToError (ListNetworksEndpoint _) st = + if st == status200 then + Nothing + else + Just $ DockerInvalidStatusCode st diff --git a/src/Docker/Client/Internal.hs b/src/Docker/Client/Internal.hs index eb3ed21..9d03516 100644 --- a/src/Docker/Client/Internal.hs +++ b/src/Docker/Client/Internal.hs @@ -1,17 +1,18 @@ module Docker.Client.Internal where -import Blaze.ByteString.Builder (toByteString) -import qualified Data.Aeson as JSON -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BSC -import qualified Data.Conduit.Binary as CB -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import qualified Network.HTTP.Client as HTTP -import Network.HTTP.Conduit (requestBodySourceChunked) -import Network.HTTP.Types (Query, encodePath, - encodePathSegments) -import Prelude hiding (all) +import Blaze.ByteString.Builder (toByteString) +import qualified Data.Aeson as JSON +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy.Char8 as BSLC +import qualified Data.Conduit.Binary as CB +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified Network.HTTP.Client as HTTP +import Network.HTTP.Conduit (requestBodySourceChunked) +import Network.HTTP.Types (Query, encodePath, + encodePathSegments) +import Prelude hiding (all) import Docker.Client.Types @@ -78,6 +79,7 @@ getEndpoint v (CreateImageEndpoint name tag _) = encodeURLWithQuery [v, "images" getEndpoint v (DeleteImageEndpoint _ cid) = encodeURL [v, "images", fromImageID cid] getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"] getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid] +getEndpoint v (ListNetworksEndpoint nfs) = encodeURLWithQuery [v, "networks"] [("filters", Just . BSLC.toStrict $ JSON.encode nfs)] getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody getEndpointRequestBody VersionEndpoint = Nothing @@ -101,6 +103,7 @@ getEndpointRequestBody (DeleteImageEndpoint _ _) = Nothing getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS (JSON.encode opts) getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing +getEndpointRequestBody (ListNetworksEndpoint _) = Nothing getEndpointContentType :: Endpoint -> BSC.ByteString getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar" diff --git a/src/Docker/Client/Types.hs b/src/Docker/Client/Types.hs index 118f7d0..9a1a3a5 100644 --- a/src/Docker/Client/Types.hs +++ b/src/Docker/Client/Types.hs @@ -76,6 +76,15 @@ module Docker.Client.Types ( , HostConfig(..) , defaultHostConfig , NetworkingConfig(..) + , NetworkScope(..) + , CIDR(..) + , IPAMDriver(..) + , IPAMConfig(..) + , IPAM(..) + , NetworkContainer(..) + , NetworkDetails(..) + , NetworkType(..) + , NetworkFilter(..) , EndpointConfig(..) , Ulimit(..) , ContainerResources(..) @@ -114,6 +123,7 @@ import qualified Data.Text as T import Data.Time.Clock (UTCTime) import qualified Data.Vector as V import GHC.Generics (Generic) +import Numeric (readDec) import Prelude hiding (all, tail) import Text.Read (readMaybe) @@ -139,6 +149,7 @@ data Endpoint = | DeleteImageEndpoint ImageDeleteOpts ImageID | CreateNetworkEndpoint CreateNetworkOpts | RemoveNetworkEndpoint NetworkID + | ListNetworksEndpoint [NetworkFilter] deriving (Eq, Show) -- | We should newtype this @@ -858,6 +869,153 @@ instance ToJSON CreateNetworkOpts where , "EnableIPv6" .= createNetworkEnableIPv6 opts ] +data NetworkScope = LocalScope | GlobalScope | SwarmScope deriving (Eq, Show) + +fromNetworkScope :: NetworkScope -> Text +fromNetworkScope LocalScope = "local" +fromNetworkScope GlobalScope = "global" +fromNetworkScope SwarmScope = "swarm" + +instance ToJSON NetworkScope where + toJSON = JSON.String . fromNetworkScope + +instance FromJSON NetworkScope where + parseJSON "local" = return LocalScope + parseJSON "global" = return GlobalScope + parseJSON "swarm" = return SwarmScope + parseJSON _ = fail "Failed to parse NetworkScope" + +data CIDR = CIDR Text Int deriving (Eq, Show) + +instance FromJSON CIDR where + parseJSON (JSON.String t) = case T.splitOn "/" t of + [a,p] -> CIDR a <$> parsePrefixLen p + _ -> fail "Failed to parse CIDR" + where + parsePrefixLen p = case readDec (T.unpack p) of + (n,""):_ -> return n + _ -> fail "Failed to parse CIDR prefix length" + parseJSON _ = fail "Failed to parse CIDR" + +data IPAMDriver = DefaultIPAMDriver | NamedIPAMDriver Text deriving (Eq, Show) + +instance FromJSON IPAMDriver where + parseJSON (JSON.String "default") = return DefaultIPAMDriver + parseJSON (JSON.String t) = return $ NamedIPAMDriver t + parseJSON _ = fail "IPAMDriver is not a string" + +data IPAMConfig = IPAMConfig + { ipamConfigSubnet :: CIDR + , ipamConfigIPRange :: Maybe CIDR + , ipamSubnetGateway :: Maybe Text + , ipamConfigAuxAddress :: Maybe Text + } deriving (Eq, Show) + +instance FromJSON IPAMConfig where + parseJSON (JSON.Object o) = IPAMConfig + <$> o .: "Subnet" + <*> o .:? "IPRange" + <*> o .:? "Gateway" + <*> o .:? "AuxAddress" + parseJSON _ = fail "IPAMConfig is not an object" + +data IPAM = IPAM + { ipamDriver :: IPAMDriver + , ipamConfig :: [IPAMConfig] + , ipamOptions :: HM.HashMap Text Text + } deriving (Eq, Show) + +instance FromJSON IPAM where + parseJSON (JSON.Object o) = IPAM + <$> o .:? "Driver" .!= DefaultIPAMDriver + <*> o .:? "Config" .!= [] + <*> o .:? "Options" .!= HM.empty + parseJSON _ = fail "IPAM is not an object" + +data NetworkContainer = NetworkContainer + { networkContainerName :: Text + , networkContainerEndpointID :: Text + , networkContainerMacAddress :: Text + , networkContainerIPv4Address :: Text + , networkContainerIPv6Address :: Text + } deriving (Eq, Show) + +instance FromJSON NetworkContainer where + parseJSON (JSON.Object o) = NetworkContainer + <$> o .: "Name" + <*> o .: "EndpointID" + <*> o .: "MacAddress" + <*> o .: "IPv4Address" + <*> o .: "IPv6Address" + parseJSON _ = fail "NetworkContainer is not an object" + +data NetworkDetails = NetworkDetails + { networkDetailsName :: Text + , networkDetailsID :: NetworkID + , networkDetailsCreated :: UTCTime + , networkDetailsScope :: NetworkScope + , networkDetailsDriver :: NetworkMode + , networkDetailsEnableIPv6 :: Bool + , networkDetailsInternal :: Bool + , networkDetailsAttachable :: Bool + , networkDetailsIngress :: Bool + , networkDetailsIPAM :: IPAM + , networkDetailsOptions :: HM.HashMap Text Text + , networkDetailsLabels :: HM.HashMap Text Text + , networkDetailsContainers :: HM.HashMap Text NetworkContainer + } deriving (Eq, Show) + +instance FromJSON NetworkDetails where + parseJSON v@(JSON.Object o) = NetworkDetails + <$> o .: "Name" + <*> parseJSON v + <*> o .: "Created" + <*> o .: "Scope" + <*> o .: "Driver" + <*> o .: "EnableIPv6" + <*> o .: "Internal" + <*> o .: "Attachable" + <*> o .: "Ingress" + <*> o .: "IPAM" + <*> o .:? "Options" .!= HM.empty + <*> o .:? "Labels" .!= HM.empty + <*> o .:? "Containers" .!= HM.empty + parseJSON _ = fail "NetworkDetails is not an object" + +data NetworkType = BuiltinNetwork | CustomNetwork deriving (Eq, Show) + +fromNetworkType :: NetworkType -> Text +fromNetworkType BuiltinNetwork = "builtin" +fromNetworkType CustomNetwork = "custom" + +instance ToJSON NetworkType where + toJSON = JSON.String . fromNetworkType + +instance FromJSON NetworkType where + parseJSON (JSON.String "builtin") = return BuiltinNetwork + parseJSON (JSON.String "custom") = return CustomNetwork + parseJSON _ = fail "Failed to parse NetworkType" + +data NetworkFilter + = NetworkFilterName Text + | NetworkFilterID NetworkID + | NetworkFilterLabel Text + | NetworkFilterDriver NetworkMode + | NetworkFilterScope NetworkScope + | NetworkFilterType NetworkType + deriving (Eq, Show) + + +instance {-# OVERLAPPING #-} ToJSON [NetworkFilter] where + toJSON = object . fmap toKV + where + toKV (NetworkFilterName n) = "name" .= [n] + toKV (NetworkFilterID i) = "id" .= [fromNetworkID i] + toKV (NetworkFilterLabel l) = "label" .= [l] + toKV (NetworkFilterDriver d) = "driver" .= [fromNetworkMode d] + toKV (NetworkFilterScope s) = "scope" .= [fromNetworkScope s] + toKV (NetworkFilterType t) = "type" .= [fromNetworkType t] + -- TOOD: Add support for SELinux Volume labels (eg. "ro,z" or "ro/Z") -- | Set permissions on volumes that you mount in the container. data VolumePermission = ReadWrite | ReadOnly deriving (Eq, Show, Generic) @@ -1027,11 +1185,14 @@ instance FromJSON NetworkMode where parseJSON (JSON.String n) = return $ NetworkNamed n parseJSON _ = fail "Unknown NetworkMode" +fromNetworkMode :: NetworkMode -> Text +fromNetworkMode NetworkBridge = "bridge" +fromNetworkMode NetworkHost = "host" +fromNetworkMode NetworkDisabled = "none" +fromNetworkMode (NetworkNamed n) = n + instance ToJSON NetworkMode where - toJSON NetworkBridge = JSON.String "bridge" - toJSON NetworkHost = JSON.String "host" - toJSON NetworkDisabled = JSON.String "none" - toJSON (NetworkNamed n) = JSON.String n + toJSON = JSON.String . fromNetworkMode newtype NetworkID = NetworkID Text deriving (Eq, Show) diff --git a/tests/tests.hs b/tests/tests.hs index a04c9b8..1423557 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -144,6 +144,14 @@ testCreateRemoveNetwork = do removeStatus <- removeNetwork nid lift $ assertBool ("removing a network, unexpected status: " ++ show removeStatus) $ isRight removeStatus +testListNetworks :: IO () +testListNetworks = + runDocker $ do + res <- listNetworks [NetworkFilterName "bridge"] + lift $ case res of + Left _ -> assertFailure $ "listing networks, unexpected status: " ++ show res + Right ns -> assertBool "listing networks, bridge network missing" $ length ns == 1 + testLogDriverOptionsJson :: TestTree testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [test1, test2, test3] where @@ -249,6 +257,7 @@ integrationTests = , testCase "Run a dummy container with networking and read its log" testRunAndReadLogWithNetworking , testCase "Try to stop a container that doesn't exist" testStopNonexisting , testCase "Create and remove a network" testCreateRemoveNetwork + , testCase "List networks" testListNetworks ] jsonTests :: TestTree From 78e5ae268645c130bf0b1d93f8d59d1a2eb18b1d Mon Sep 17 00:00:00 2001 From: Ben Hamlin Date: Tue, 2 Jul 2019 21:39:42 -0500 Subject: [PATCH 2/7] Add inspectNetwork endpoint --- src/Docker/Client/Api.hs | 7 ++++++- src/Docker/Client/Http.hs | 5 +++++ src/Docker/Client/Internal.hs | 2 ++ src/Docker/Client/Types.hs | 7 +++++-- tests/tests.hs | 11 +++++++++-- 5 files changed, 27 insertions(+), 5 deletions(-) diff --git a/src/Docker/Client/Api.hs b/src/Docker/Client/Api.hs index 1749347..fbb5fa0 100644 --- a/src/Docker/Client/Api.hs +++ b/src/Docker/Client/Api.hs @@ -25,6 +25,7 @@ module Docker.Client.Api ( , createNetwork , removeNetwork , listNetworks + , inspectNetwork -- * Other , getDockerVersion ) where @@ -226,6 +227,10 @@ createNetwork opts = requestHelper POST (CreateNetworkEndpoint opts) >>= parseR removeNetwork :: forall m. (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError ()) removeNetwork nid = requestUnit DELETE $ RemoveNetworkEndpoint nid --- | Lists networks optionally matching a list of 'Filter's +-- | Lists networks optionally matching a list of 'NetworkFilter's. listNetworks :: forall m . (MonadIO m, MonadMask m) => [NetworkFilter] -> DockerT m (Either DockerError [NetworkDetails]) listNetworks nfs = requestHelper GET (ListNetworksEndpoint nfs) >>= parseResponse + +-- | Gets 'NetworkDetails' for a network, given its name or id. +inspectNetwork :: forall m . (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError NetworkDetails) +inspectNetwork nid = requestHelper GET (InspectNetworkEndpoint nid) >>= parseResponse diff --git a/src/Docker/Client/Http.hs b/src/Docker/Client/Http.hs index 9675ed2..781a50b 100644 --- a/src/Docker/Client/Http.hs +++ b/src/Docker/Client/Http.hs @@ -293,3 +293,8 @@ statusCodeToError (ListNetworksEndpoint _) st = Nothing else Just $ DockerInvalidStatusCode st +statusCodeToError (InspectNetworkEndpoint _) st = + if st == status200 then + Nothing + else + Just $ DockerInvalidStatusCode st diff --git a/src/Docker/Client/Internal.hs b/src/Docker/Client/Internal.hs index 9d03516..e7a492e 100644 --- a/src/Docker/Client/Internal.hs +++ b/src/Docker/Client/Internal.hs @@ -80,6 +80,7 @@ getEndpoint v (DeleteImageEndpoint _ cid) = encodeURL [v, "images", fromImageID getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"] getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid] getEndpoint v (ListNetworksEndpoint nfs) = encodeURLWithQuery [v, "networks"] [("filters", Just . BSLC.toStrict $ JSON.encode nfs)] +getEndpoint v (InspectNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid] getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody getEndpointRequestBody VersionEndpoint = Nothing @@ -104,6 +105,7 @@ getEndpointRequestBody (DeleteImageEndpoint _ _) = Nothing getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS (JSON.encode opts) getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing getEndpointRequestBody (ListNetworksEndpoint _) = Nothing +getEndpointRequestBody (InspectNetworkEndpoint _) = Nothing getEndpointContentType :: Endpoint -> BSC.ByteString getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar" diff --git a/src/Docker/Client/Types.hs b/src/Docker/Client/Types.hs index 9a1a3a5..a0b83ee 100644 --- a/src/Docker/Client/Types.hs +++ b/src/Docker/Client/Types.hs @@ -84,6 +84,7 @@ module Docker.Client.Types ( , NetworkContainer(..) , NetworkDetails(..) , NetworkType(..) + , NetworkName , NetworkFilter(..) , EndpointConfig(..) , Ulimit(..) @@ -150,6 +151,7 @@ data Endpoint = | CreateNetworkEndpoint CreateNetworkOpts | RemoveNetworkEndpoint NetworkID | ListNetworksEndpoint [NetworkFilter] + | InspectNetworkEndpoint NetworkID deriving (Eq, Show) -- | We should newtype this @@ -933,7 +935,7 @@ instance FromJSON IPAM where parseJSON _ = fail "IPAM is not an object" data NetworkContainer = NetworkContainer - { networkContainerName :: Text + { networkContainerName :: ContainerName , networkContainerEndpointID :: Text , networkContainerMacAddress :: Text , networkContainerIPv4Address :: Text @@ -988,6 +990,8 @@ fromNetworkType :: NetworkType -> Text fromNetworkType BuiltinNetwork = "builtin" fromNetworkType CustomNetwork = "custom" +type NetworkName = Text + instance ToJSON NetworkType where toJSON = JSON.String . fromNetworkType @@ -1005,7 +1009,6 @@ data NetworkFilter | NetworkFilterType NetworkType deriving (Eq, Show) - instance {-# OVERLAPPING #-} ToJSON [NetworkFilter] where toJSON = object . fmap toKV where diff --git a/tests/tests.hs b/tests/tests.hs index 1423557..d0658a6 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -149,8 +149,15 @@ testListNetworks = runDocker $ do res <- listNetworks [NetworkFilterName "bridge"] lift $ case res of - Left _ -> assertFailure $ "listing networks, unexpected status: " ++ show res - Right ns -> assertBool "listing networks, bridge network missing" $ length ns == 1 + Left _ -> assertFailure $ "listing networks, unexpected status: " ++ show res + Right (d:_) -> assertBool "listing networks, bridge network missing" $ networkDetailsName d == "bridge" + +testInspectNetwork :: IO () +testInspectNetwork = + runDocker $ do + res <- inspectNetwork . fromJust $ toNetworkID "bridge" + lift $ assertBool ("inspecting networks, unewxpected status: " ++ show res) $ isRight res + testLogDriverOptionsJson :: TestTree testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [test1, test2, test3] From 926a5cb5bf285829b59f29e8a4a498c15681722d Mon Sep 17 00:00:00 2001 From: Ben Hamlin Date: Thu, 4 Jul 2019 15:25:23 -0500 Subject: [PATCH 3/7] Add connectNetwork endpoint --- 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 | 18 ++++++++++++- 5 files changed, 80 insertions(+), 1 deletion(-) diff --git a/src/Docker/Client/Api.hs b/src/Docker/Client/Api.hs index fbb5fa0..948e25f 100644 --- a/src/Docker/Client/Api.hs +++ b/src/Docker/Client/Api.hs @@ -26,6 +26,7 @@ module Docker.Client.Api ( , removeNetwork , listNetworks , inspectNetwork + , connectNetwork -- * Other , getDockerVersion ) where @@ -234,3 +235,7 @@ listNetworks nfs = requestHelper GET (ListNetworksEndpoint nfs) >>= parseRespons -- | Gets 'NetworkDetails' for a network, given its name or id. inspectNetwork :: forall m . (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError NetworkDetails) inspectNetwork nid = requestHelper GET (InspectNetworkEndpoint nid) >>= parseResponse + +-- | Connects a container to a network. +connectNetwork :: forall m . (MonadIO m, MonadMask m) => NetworkID -> ConnectConfig -> DockerT m (Either DockerError ()) +connectNetwork nid cfg = requestUnit POST $ ConnectNetworkEndpoint nid cfg diff --git a/src/Docker/Client/Http.hs b/src/Docker/Client/Http.hs index 781a50b..6868c20 100644 --- a/src/Docker/Client/Http.hs +++ b/src/Docker/Client/Http.hs @@ -298,3 +298,8 @@ statusCodeToError (InspectNetworkEndpoint _) st = Nothing else Just $ DockerInvalidStatusCode st +statusCodeToError (ConnectNetworkEndpoint _ _) st = + if st == status200 then + Nothing + else + Just $ DockerInvalidStatusCode st diff --git a/src/Docker/Client/Internal.hs b/src/Docker/Client/Internal.hs index e7a492e..994106c 100644 --- a/src/Docker/Client/Internal.hs +++ b/src/Docker/Client/Internal.hs @@ -81,6 +81,7 @@ getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"] getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid] getEndpoint v (ListNetworksEndpoint nfs) = encodeURLWithQuery [v, "networks"] [("filters", Just . BSLC.toStrict $ JSON.encode nfs)] getEndpoint v (InspectNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid] +getEndpoint v (ConnectNetworkEndpoint nid _) = encodeURL [v, "networks", fromNetworkID nid, "connect"] getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody getEndpointRequestBody VersionEndpoint = Nothing @@ -106,6 +107,7 @@ getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing getEndpointRequestBody (ListNetworksEndpoint _) = Nothing getEndpointRequestBody (InspectNetworkEndpoint _) = Nothing +getEndpointRequestBody (ConnectNetworkEndpoint _ cfg) = Just $ HTTP.RequestBodyLBS (JSON.encode cfg) getEndpointContentType :: Endpoint -> BSC.ByteString getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar" diff --git a/src/Docker/Client/Types.hs b/src/Docker/Client/Types.hs index a0b83ee..57be9c9 100644 --- a/src/Docker/Client/Types.hs +++ b/src/Docker/Client/Types.hs @@ -86,6 +86,12 @@ module Docker.Client.Types ( , NetworkType(..) , NetworkName , NetworkFilter(..) + , ConnectConfig(..) + , defaultConnectConfig + , EndpointSettings(..) + , defaultEndpointSettings + , IPAMSettings(..) + , defaultIPAMSettings , EndpointConfig(..) , Ulimit(..) , ContainerResources(..) @@ -152,6 +158,7 @@ data Endpoint = | RemoveNetworkEndpoint NetworkID | ListNetworksEndpoint [NetworkFilter] | InspectNetworkEndpoint NetworkID + | ConnectNetworkEndpoint NetworkID ConnectConfig deriving (Eq, Show) -- | We should newtype this @@ -1019,6 +1026,50 @@ instance {-# OVERLAPPING #-} ToJSON [NetworkFilter] where toKV (NetworkFilterScope s) = "scope" .= [fromNetworkScope s] toKV (NetworkFilterType t) = "type" .= [fromNetworkType t] +data ConnectConfig = ConnectConfig + { connectContainer :: Text + , connectEndpointConfig :: EndpointSettings + } deriving (Eq, Show, Generic) + +instance ToJSON ConnectConfig where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = drop 7 } + +defaultConnectConfig :: Text -> ConnectConfig +defaultConnectConfig = flip ConnectConfig defaultEndpointSettings + +data EndpointSettings = EndpointSettings + { endpointIPAMConfig :: IPAMSettings + , endpointLinks :: [Text] + , endpointAliases :: [Text] + , endpointNetworkID :: Maybe Text + , endpointEndpointID :: Maybe Text + , endpointGateway :: Maybe Text + , endpointIPAddress :: Maybe Text + , endpointIPPrefixLen :: Maybe Int + , endpointIPv6Gateway :: Maybe Text + , endpointGlobalIPv6Address :: Maybe Text + , endpointGlobalIPv6PrefixLen :: Maybe Int + , endpointMacAddress :: Maybe Text + } deriving (Eq, Show, Generic) + +instance ToJSON EndpointSettings where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = drop 8 } + +defaultEndpointSettings :: EndpointSettings +defaultEndpointSettings = EndpointSettings defaultIPAMSettings [] [] Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +data IPAMSettings = IPAMSettings + { ipamIPv4Address :: Maybe Text + , ipamIPv6Address :: Maybe Text + , ipamLinkLocalIPs :: [Text] + } deriving (Eq, Show, Generic) + +instance ToJSON IPAMSettings where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = drop 4 } + +defaultIPAMSettings :: IPAMSettings +defaultIPAMSettings = IPAMSettings Nothing Nothing [] + -- TOOD: Add support for SELinux Volume labels (eg. "ro,z" or "ro/Z") -- | Set permissions on volumes that you mount in the container. data VolumePermission = ReadWrite | ReadOnly deriving (Eq, Show, Generic) diff --git a/tests/tests.hs b/tests/tests.hs index d0658a6..cf2e503 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -156,8 +156,22 @@ testInspectNetwork :: IO () testInspectNetwork = runDocker $ do res <- inspectNetwork . fromJust $ toNetworkID "bridge" - lift $ assertBool ("inspecting networks, unewxpected status: " ++ show res) $ isRight res + lift $ assertBool ("inspecting networks, unexpected status: " ++ show res) $ isRight res +testConnectNetwork :: IO () +testConnectNetwork = + runDocker $ do + containerId <- fromRight =<< createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing + networkId <- fromRight =<< createNetwork (defaultCreateNetworkOpts "mynetwork") + res <- connectNetwork networkId . defaultConnectConfig $ fromContainerID containerId + lift $ assertBool ("connecting network, unexpected status: " ++ show res) $ isRight res + details <- fromRight =<< inspectContainer containerId + _ <- deleteContainer defaultContainerDeleteOpts containerId + _ <- removeNetwork networkId + let networks = networkMode <$> (networkSettingsNetworks . networkSettings) details + lift $ assertBool "connecting network failed" $ NetworkNamed "mynetwork" `elem` networks + where + networkMode (Network mode _) = mode testLogDriverOptionsJson :: TestTree testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [test1, test2, test3] @@ -265,6 +279,8 @@ integrationTests = , testCase "Try to stop a container that doesn't exist" testStopNonexisting , testCase "Create and remove a network" testCreateRemoveNetwork , testCase "List networks" testListNetworks + , testCase "Inspect a network" testInspectNetwork + , testCase "Connect a container to a network" testConnectNetwork ] jsonTests :: TestTree From 1147188a30c8478eec76a79933651c6fe28c64d7 Mon Sep 17 00:00:00 2001 From: Ben Hamlin Date: Fri, 5 Jul 2019 21:18:10 -0500 Subject: [PATCH 4/7] Add disconnectNetwork endpoint --- src/Docker/Client/Api.hs | 5 +++++ src/Docker/Client/Http.hs | 5 +++++ src/Docker/Client/Internal.hs | 2 ++ src/Docker/Client/Types.hs | 14 ++++++++++++++ tests/tests.hs | 26 ++++++++++++++++++++++++++ 5 files changed, 52 insertions(+) diff --git a/src/Docker/Client/Api.hs b/src/Docker/Client/Api.hs index 948e25f..774d535 100644 --- a/src/Docker/Client/Api.hs +++ b/src/Docker/Client/Api.hs @@ -27,6 +27,7 @@ module Docker.Client.Api ( , listNetworks , inspectNetwork , connectNetwork + , disconnectNetwork -- * Other , getDockerVersion ) where @@ -239,3 +240,7 @@ inspectNetwork nid = requestHelper GET (InspectNetworkEndpoint nid) >>= parseRes -- | Connects a container to a network. connectNetwork :: forall m . (MonadIO m, MonadMask m) => NetworkID -> ConnectConfig -> DockerT m (Either DockerError ()) connectNetwork nid cfg = requestUnit POST $ ConnectNetworkEndpoint nid cfg + +-- | Disconnects a container from a network. +disconnectNetwork :: forall m . (MonadIO m, MonadMask m) => NetworkID -> DisconnectConfig -> DockerT m (Either DockerError ()) +disconnectNetwork nid cfg = requestUnit POST $ DisconnectNetworkEndpoint nid cfg diff --git a/src/Docker/Client/Http.hs b/src/Docker/Client/Http.hs index 6868c20..213c75d 100644 --- a/src/Docker/Client/Http.hs +++ b/src/Docker/Client/Http.hs @@ -303,3 +303,8 @@ statusCodeToError (ConnectNetworkEndpoint _ _) st = Nothing else Just $ DockerInvalidStatusCode st +statusCodeToError (DisconnectNetworkEndpoint _ _) st = + if st == status200 then + Nothing + else + Just $ DockerInvalidStatusCode st diff --git a/src/Docker/Client/Internal.hs b/src/Docker/Client/Internal.hs index 994106c..cdb62ec 100644 --- a/src/Docker/Client/Internal.hs +++ b/src/Docker/Client/Internal.hs @@ -82,6 +82,7 @@ getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetwor getEndpoint v (ListNetworksEndpoint nfs) = encodeURLWithQuery [v, "networks"] [("filters", Just . BSLC.toStrict $ JSON.encode nfs)] getEndpoint v (InspectNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid] getEndpoint v (ConnectNetworkEndpoint nid _) = encodeURL [v, "networks", fromNetworkID nid, "connect"] +getEndpoint v (DisconnectNetworkEndpoint nid _) = encodeURL [v, "networks", fromNetworkID nid, "disconnect"] getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody getEndpointRequestBody VersionEndpoint = Nothing @@ -108,6 +109,7 @@ getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing getEndpointRequestBody (ListNetworksEndpoint _) = Nothing getEndpointRequestBody (InspectNetworkEndpoint _) = Nothing getEndpointRequestBody (ConnectNetworkEndpoint _ cfg) = Just $ HTTP.RequestBodyLBS (JSON.encode cfg) +getEndpointRequestBody (DisconnectNetworkEndpoint _ cfg) = Just $ HTTP.RequestBodyLBS (JSON.encode cfg) getEndpointContentType :: Endpoint -> BSC.ByteString getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar" diff --git a/src/Docker/Client/Types.hs b/src/Docker/Client/Types.hs index 57be9c9..4bf5c4b 100644 --- a/src/Docker/Client/Types.hs +++ b/src/Docker/Client/Types.hs @@ -88,6 +88,8 @@ module Docker.Client.Types ( , NetworkFilter(..) , ConnectConfig(..) , defaultConnectConfig + , DisconnectConfig(..) + , defaultDisconnectConfig , EndpointSettings(..) , defaultEndpointSettings , IPAMSettings(..) @@ -159,6 +161,7 @@ data Endpoint = | ListNetworksEndpoint [NetworkFilter] | InspectNetworkEndpoint NetworkID | ConnectNetworkEndpoint NetworkID ConnectConfig + | DisconnectNetworkEndpoint NetworkID DisconnectConfig deriving (Eq, Show) -- | We should newtype this @@ -1037,6 +1040,17 @@ instance ToJSON ConnectConfig where defaultConnectConfig :: Text -> ConnectConfig defaultConnectConfig = flip ConnectConfig defaultEndpointSettings +data DisconnectConfig = DisconnectConfig + { disconnectContainer :: Text + , disconnectForce :: Bool + } deriving (Eq, Show, Generic) + +instance ToJSON DisconnectConfig where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = drop 10 } + +defaultDisconnectConfig :: Text -> DisconnectConfig +defaultDisconnectConfig = flip DisconnectConfig False + data EndpointSettings = EndpointSettings { endpointIPAMConfig :: IPAMSettings , endpointLinks :: [Text] diff --git a/tests/tests.hs b/tests/tests.hs index cf2e503..7df994f 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -173,6 +173,19 @@ testConnectNetwork = where networkMode (Network mode _) = mode +testDisconnectNetwork :: IO () +testDisconnectNetwork = + runDocker $ do + containerId <- fromRight =<< createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing + res <- disconnectNetwork (fromJust $ toNetworkID "bridge") (defaultDisconnectConfig $ fromContainerID containerId) + lift $ assertBool ("disconnecting network, unexpected status: " ++ show res) $ isRight res + details <- fromRight =<< inspectContainer containerId + _ <- deleteContainer defaultContainerDeleteOpts containerId + let networks = networkMode <$> (networkSettingsNetworks . networkSettings) details + lift $ assertBool "disconnecting network failed" $ null networks + where + networkMode (Network mode _) = mode + testLogDriverOptionsJson :: TestTree testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [test1, test2, test3] where @@ -265,6 +278,17 @@ testNetworkingConfigJson = testGroup "Testing NetworkingConfig JSON" [testSample ] ] +testDisconnectConfigJson :: TestTree +testDisconnectConfigJson = testGroup "Testing DisconnectConfig JSON" [testSampleEncode] + where + testSampleEncode = + let config = DisconnectConfig "mycontainer" True + in testCase "Test toJSON" $ assert $ JSON.toJSON config == + JSON.object + [ "Container" .= ("mycontainer" :: Text) + , "Force" .= True + ] + integrationTests :: TestTree integrationTests = testGroup @@ -281,6 +305,7 @@ integrationTests = , testCase "List networks" testListNetworks , testCase "Inspect a network" testInspectNetwork , testCase "Connect a container to a network" testConnectNetwork + , testCase "Disconnect a container from a network" testDisconnectNetwork ] jsonTests :: TestTree @@ -294,6 +319,7 @@ jsonTests = , testEntrypointJson , testEnvVarJson , testNetworkingConfigJson + , testDisconnectConfigJson ] setup :: IO () From b550387c25d94e9e813266c6ed876b94e8d7c238 Mon Sep 17 00:00:00 2001 From: Ben Hamlin Date: Tue, 9 Jul 2019 13:23:58 -0500 Subject: [PATCH 5/7] Add pruneNetworks endpoint --- src/Docker/Client/Api.hs | 5 +++++ src/Docker/Client/Http.hs | 5 +++++ src/Docker/Client/Internal.hs | 3 ++- src/Docker/Client/Types.hs | 39 +++++++++++++++++++++++++++++++++++ tests/tests.hs | 3 ++- 5 files changed, 53 insertions(+), 2 deletions(-) diff --git a/src/Docker/Client/Api.hs b/src/Docker/Client/Api.hs index 774d535..8e11b52 100644 --- a/src/Docker/Client/Api.hs +++ b/src/Docker/Client/Api.hs @@ -28,6 +28,7 @@ module Docker.Client.Api ( , inspectNetwork , connectNetwork , disconnectNetwork + , pruneNetworks -- * Other , getDockerVersion ) where @@ -244,3 +245,7 @@ connectNetwork nid cfg = requestUnit POST $ ConnectNetworkEndpoint nid cfg -- | Disconnects a container from a network. disconnectNetwork :: forall m . (MonadIO m, MonadMask m) => NetworkID -> DisconnectConfig -> DockerT m (Either DockerError ()) disconnectNetwork nid cfg = requestUnit POST $ DisconnectNetworkEndpoint nid cfg + +-- | Remove unused networks +pruneNetworks :: forall m . (MonadIO m, MonadMask m) => PruneFilter -> DockerT m (Either DockerError NetworksDeleted) +pruneNetworks pfs = requestHelper POST (PruneNetworksEndpoint pfs) >>= parseResponse diff --git a/src/Docker/Client/Http.hs b/src/Docker/Client/Http.hs index 213c75d..f8083c3 100644 --- a/src/Docker/Client/Http.hs +++ b/src/Docker/Client/Http.hs @@ -308,3 +308,8 @@ statusCodeToError (DisconnectNetworkEndpoint _ _) st = Nothing else Just $ DockerInvalidStatusCode st +statusCodeToError (PruneNetworksEndpoint _) st = + if st == status200 then + Nothing + else + Just $ DockerInvalidStatusCode st diff --git a/src/Docker/Client/Internal.hs b/src/Docker/Client/Internal.hs index cdb62ec..0a23d53 100644 --- a/src/Docker/Client/Internal.hs +++ b/src/Docker/Client/Internal.hs @@ -83,6 +83,7 @@ getEndpoint v (ListNetworksEndpoint nfs) = encodeURLWithQuery [v, "networks"] [( getEndpoint v (InspectNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid] getEndpoint v (ConnectNetworkEndpoint nid _) = encodeURL [v, "networks", fromNetworkID nid, "connect"] getEndpoint v (DisconnectNetworkEndpoint nid _) = encodeURL [v, "networks", fromNetworkID nid, "disconnect"] +getEndpoint v (PruneNetworksEndpoint pf) = encodeURLWithQuery [v, "networks", "prune"] [("filters", Just . BSLC.toStrict $ JSON.encode pf)] getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody getEndpointRequestBody VersionEndpoint = Nothing @@ -110,8 +111,8 @@ getEndpointRequestBody (ListNetworksEndpoint _) = Nothing getEndpointRequestBody (InspectNetworkEndpoint _) = Nothing getEndpointRequestBody (ConnectNetworkEndpoint _ cfg) = Just $ HTTP.RequestBodyLBS (JSON.encode cfg) getEndpointRequestBody (DisconnectNetworkEndpoint _ cfg) = Just $ HTTP.RequestBodyLBS (JSON.encode cfg) +getEndpointRequestBody (PruneNetworksEndpoint _) = Nothing getEndpointContentType :: Endpoint -> BSC.ByteString getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar" getEndpointContentType _ = BSC.pack "application/json; charset=utf-8" - diff --git a/src/Docker/Client/Types.hs b/src/Docker/Client/Types.hs index 4bf5c4b..bb53d29 100644 --- a/src/Docker/Client/Types.hs +++ b/src/Docker/Client/Types.hs @@ -90,6 +90,9 @@ module Docker.Client.Types ( , defaultConnectConfig , DisconnectConfig(..) , defaultDisconnectConfig + , PruneFilter(..) + , defaultPruneFilter + , NetworksDeleted(..) , EndpointSettings(..) , defaultEndpointSettings , IPAMSettings(..) @@ -118,6 +121,7 @@ module Docker.Client.Types ( , MemoryConstraintSize(..) ) where +import Control.Monad (join) import Data.Aeson (FromJSON, ToJSON, genericParseJSON, genericToJSON, object, parseJSON, toJSON, (.!=), (.:), (.:?), (.=)) @@ -125,6 +129,7 @@ import qualified Data.Aeson as JSON import Data.Aeson.Types (defaultOptions, fieldLabelModifier) import Data.Char (isAlphaNum, toUpper) import qualified Data.HashMap.Strict as HM +import Data.Maybe (maybeToList, catMaybes) import Data.Monoid ((<>)) import Data.Scientific (floatingOrInteger) import Data.Text (Text) @@ -162,6 +167,7 @@ data Endpoint = | InspectNetworkEndpoint NetworkID | ConnectNetworkEndpoint NetworkID ConnectConfig | DisconnectNetworkEndpoint NetworkID DisconnectConfig + | PruneNetworksEndpoint PruneFilter deriving (Eq, Show) -- | We should newtype this @@ -1051,6 +1057,39 @@ instance ToJSON DisconnectConfig where defaultDisconnectConfig :: Text -> DisconnectConfig defaultDisconnectConfig = flip DisconnectConfig False +data PruneFilter = PruneFilter + { pruneFilterUntil :: Maybe Text + -- ^ Can be a Unix timestamp, a date-formatted timestamp, or a duration, + -- such as @10m@ or @1h30m@. + , pruneFilterIncludeLabels :: [(Text, (Maybe Text))] + , pruneFilterExcludeLabels :: [(Text, (Maybe Text))] + } deriving (Eq, Show) + +instance ToJSON PruneFilter where + toJSON pf = object . catMaybes $ + [ "until" .=? maybeToList (pruneFilterUntil pf) + , "label" .=? (constructLabel <$> pruneFilterIncludeLabels pf) + , "label!" .=? (constructLabel <$> pruneFilterExcludeLabels pf) + ] + where + _ .=? [] = Nothing + k .=? l = Just $ k .= l + +constructLabel :: (Text, Maybe Text) -> Text +constructLabel (k, Just v) = T.concat [k, "=", v] +constructLabel (k, Nothing) = k + +defaultPruneFilter :: PruneFilter +defaultPruneFilter = PruneFilter Nothing [] [] + +newtype NetworksDeleted = NetworksDeleted [Text] + deriving (Eq, Show) + +instance FromJSON NetworksDeleted where + parseJSON (JSON.Object o) = + NetworksDeleted . join . maybeToList <$> o .: "NetworksDeleted" + parseJSON _ = fail $ "NetworksDeleted is not an object" + data EndpointSettings = EndpointSettings { endpointIPAMConfig :: IPAMSettings , endpointLinks :: [Text] diff --git a/tests/tests.hs b/tests/tests.hs index 7df994f..4a7eb76 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -11,7 +11,7 @@ import Test.Tasty.QuickCheck (testProperty) import Control.Concurrent (threadDelay) import Control.Lens ((^.), (^?)) -import Control.Monad (forM_) +import Control.Monad (forM_, when, (<=<)) import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) import qualified Data.Aeson as JSON @@ -23,6 +23,7 @@ import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as HM import Data.Int (Int) +import Data.List ((\\)) import qualified Data.Map as M import Data.Maybe (fromJust, isJust, isNothing, listToMaybe) import Data.Monoid From af843a1ffd321dc1e54067d73cbec33e9bd44544 Mon Sep 17 00:00:00 2001 From: Ben Hamlin Date: Tue, 9 Jul 2019 13:35:39 -0500 Subject: [PATCH 6/7] Improve handling of filters in listNetworks --- src/Docker/Client/Api.hs | 2 +- src/Docker/Client/Internal.hs | 2 +- src/Docker/Client/Types.hs | 49 ++++++++++++++++++++--------------- tests/tests.hs | 2 +- 4 files changed, 31 insertions(+), 24 deletions(-) diff --git a/src/Docker/Client/Api.hs b/src/Docker/Client/Api.hs index 8e11b52..cf62187 100644 --- a/src/Docker/Client/Api.hs +++ b/src/Docker/Client/Api.hs @@ -231,7 +231,7 @@ removeNetwork :: forall m. (MonadIO m, MonadMask m) => NetworkID -> DockerT m (E removeNetwork nid = requestUnit DELETE $ RemoveNetworkEndpoint nid -- | Lists networks optionally matching a list of 'NetworkFilter's. -listNetworks :: forall m . (MonadIO m, MonadMask m) => [NetworkFilter] -> DockerT m (Either DockerError [NetworkDetails]) +listNetworks :: forall m . (MonadIO m, MonadMask m) => NetworkFilter -> DockerT m (Either DockerError [NetworkDetails]) listNetworks nfs = requestHelper GET (ListNetworksEndpoint nfs) >>= parseResponse -- | Gets 'NetworkDetails' for a network, given its name or id. diff --git a/src/Docker/Client/Internal.hs b/src/Docker/Client/Internal.hs index 0a23d53..3c5777b 100644 --- a/src/Docker/Client/Internal.hs +++ b/src/Docker/Client/Internal.hs @@ -79,7 +79,7 @@ getEndpoint v (CreateImageEndpoint name tag _) = encodeURLWithQuery [v, "images" getEndpoint v (DeleteImageEndpoint _ cid) = encodeURL [v, "images", fromImageID cid] getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"] getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid] -getEndpoint v (ListNetworksEndpoint nfs) = encodeURLWithQuery [v, "networks"] [("filters", Just . BSLC.toStrict $ JSON.encode nfs)] +getEndpoint v (ListNetworksEndpoint nf) = encodeURLWithQuery [v, "networks"] [("filters", Just . BSLC.toStrict $ JSON.encode nf)] getEndpoint v (InspectNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid] getEndpoint v (ConnectNetworkEndpoint nid _) = encodeURL [v, "networks", fromNetworkID nid, "connect"] getEndpoint v (DisconnectNetworkEndpoint nid _) = encodeURL [v, "networks", fromNetworkID nid, "disconnect"] diff --git a/src/Docker/Client/Types.hs b/src/Docker/Client/Types.hs index bb53d29..350e3c6 100644 --- a/src/Docker/Client/Types.hs +++ b/src/Docker/Client/Types.hs @@ -86,6 +86,7 @@ module Docker.Client.Types ( , NetworkType(..) , NetworkName , NetworkFilter(..) + , defaultNetworkFilter , ConnectConfig(..) , defaultConnectConfig , DisconnectConfig(..) @@ -163,7 +164,7 @@ data Endpoint = | DeleteImageEndpoint ImageDeleteOpts ImageID | CreateNetworkEndpoint CreateNetworkOpts | RemoveNetworkEndpoint NetworkID - | ListNetworksEndpoint [NetworkFilter] + | ListNetworksEndpoint NetworkFilter | InspectNetworkEndpoint NetworkID | ConnectNetworkEndpoint NetworkID ConnectConfig | DisconnectNetworkEndpoint NetworkID DisconnectConfig @@ -1016,24 +1017,34 @@ instance FromJSON NetworkType where parseJSON (JSON.String "custom") = return CustomNetwork parseJSON _ = fail "Failed to parse NetworkType" -data NetworkFilter - = NetworkFilterName Text - | NetworkFilterID NetworkID - | NetworkFilterLabel Text - | NetworkFilterDriver NetworkMode - | NetworkFilterScope NetworkScope - | NetworkFilterType NetworkType - deriving (Eq, Show) +data NetworkFilter = NetworkFilter + { networkFilterNames :: [Text] + , networkFilterIDs :: [NetworkID] + , networkFilterDrivers :: [NetworkMode] + , networkFilterScopes :: [NetworkScope] + , networkFilterTypes :: [NetworkType] + , networkFilterLabels :: [(Text, (Maybe Text))] + } deriving (Eq, Show) -instance {-# OVERLAPPING #-} ToJSON [NetworkFilter] where - toJSON = object . fmap toKV +instance ToJSON NetworkFilter where + toJSON nf = object . catMaybes $ + [ "name" .=? networkFilterNames nf + , "id" .=? (fromNetworkID <$> networkFilterIDs nf) + , "driver" .=? (fromNetworkMode <$> networkFilterDrivers nf) + , "scope" .=? (fromNetworkScope <$> networkFilterScopes nf) + , "type" .=? (fromNetworkType <$> networkFilterTypes nf) + , "label" .=? (constructLabel <$> networkFilterLabels nf) + ] where - toKV (NetworkFilterName n) = "name" .= [n] - toKV (NetworkFilterID i) = "id" .= [fromNetworkID i] - toKV (NetworkFilterLabel l) = "label" .= [l] - toKV (NetworkFilterDriver d) = "driver" .= [fromNetworkMode d] - toKV (NetworkFilterScope s) = "scope" .= [fromNetworkScope s] - toKV (NetworkFilterType t) = "type" .= [fromNetworkType t] + _ .=? [] = Nothing + k .=? l = Just $ k .= l + +constructLabel :: (Text, Maybe Text) -> Text +constructLabel (k, Just v) = T.concat [k, "=", v] +constructLabel (k, Nothing) = k + +defaultNetworkFilter :: NetworkFilter +defaultNetworkFilter = NetworkFilter [] [] [] [] [] [] data ConnectConfig = ConnectConfig { connectContainer :: Text @@ -1075,10 +1086,6 @@ instance ToJSON PruneFilter where _ .=? [] = Nothing k .=? l = Just $ k .= l -constructLabel :: (Text, Maybe Text) -> Text -constructLabel (k, Just v) = T.concat [k, "=", v] -constructLabel (k, Nothing) = k - defaultPruneFilter :: PruneFilter defaultPruneFilter = PruneFilter Nothing [] [] diff --git a/tests/tests.hs b/tests/tests.hs index 4a7eb76..e167549 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -148,7 +148,7 @@ testCreateRemoveNetwork = do testListNetworks :: IO () testListNetworks = runDocker $ do - res <- listNetworks [NetworkFilterName "bridge"] + res <- listNetworks defaultNetworkFilter {networkFilterNames = ["bridge"]} lift $ case res of Left _ -> assertFailure $ "listing networks, unexpected status: " ++ show res Right (d:_) -> assertBool "listing networks, bridge network missing" $ networkDetailsName d == "bridge" From 2da7b4eff6ca53c5daabad275b853b21904b0026 Mon Sep 17 00:00:00 2001 From: Ben Hamlin Date: Tue, 9 Jul 2019 16:37:06 -0500 Subject: [PATCH 7/7] Add the rest of the fields through AVI version 1.29 to 'CreateNetworkOpts' --- src/Docker/Client/Types.hs | 69 +++++++++++++++++++++++++------------- tests/tests.hs | 16 +++++++++ 2 files changed, 62 insertions(+), 23 deletions(-) diff --git a/src/Docker/Client/Types.hs b/src/Docker/Client/Types.hs index 350e3c6..e633dae 100644 --- a/src/Docker/Client/Types.hs +++ b/src/Docker/Client/Types.hs @@ -81,6 +81,7 @@ module Docker.Client.Types ( , IPAMDriver(..) , IPAMConfig(..) , IPAM(..) + , defaultIPAM , NetworkContainer(..) , NetworkDetails(..) , NetworkType(..) @@ -127,7 +128,7 @@ import Data.Aeson (FromJSON, ToJSON, genericParseJSON, genericToJSON, object, parseJSON, toJSON, (.!=), (.:), (.:?), (.=)) import qualified Data.Aeson as JSON -import Data.Aeson.Types (defaultOptions, fieldLabelModifier) +import Data.Aeson.Types (defaultOptions, fieldLabelModifier, omitNothingFields) import Data.Char (isAlphaNum, toUpper) import qualified Data.HashMap.Strict as HM import Data.Maybe (maybeToList, catMaybes) @@ -860,12 +861,17 @@ defaultLogOpts = LogOpts { stdout = True -- | Options for creating a network data CreateNetworkOpts = CreateNetworkOpts - { createNetworkName :: Text -- ^ The network's name - , createNetworkCheckDuplicate :: Bool -- ^ Check for networks with duplicate names. - , createNetworkDriver :: Text -- ^ Name of the network driver plugin to use. - , createNetworkInternal :: Bool -- ^ Restrict external access to the network. - , createNetworkEnableIPv6 :: Bool -- ^ Enable IPv6 on the network. - } deriving (Eq, Show) + { createNetworkName :: Text -- ^ The network's name + , createNetworkCheckDuplicate :: Bool -- ^ Check for networks with duplicate names. + , createNetworkDriver :: NetworkMode -- ^ Name of the network driver plugin to use. + , createNetworkInternal :: Bool -- ^ Restrict external access to the network. + , createNetworkAttachable :: Bool -- ^ Network is manually attachable in swarm mode. + , createNetworkIngress :: Bool -- ^ Network is a swarm-mode network. + , createNetworkIPAM :: IPAM -- ^ Address management configuration + , createNetworkEnableIPv6 :: Bool -- ^ Enable IPv6 on the network. + , createNetworkOptions :: HM.HashMap Text Text -- ^ Options to pass to the driver. + , createNetworkLabels :: [Label] -- ^ Identifying labels for the network. + } deriving (Eq, Show, Generic) -- | Sensible defalut for create network options defaultCreateNetworkOpts :: Text -> CreateNetworkOpts @@ -873,20 +879,19 @@ defaultCreateNetworkOpts name = CreateNetworkOpts { createNetworkName = name , createNetworkCheckDuplicate = False - , createNetworkDriver = "bridge" + , createNetworkDriver = NetworkBridge , createNetworkInternal = True + , createNetworkAttachable = False + , createNetworkIngress = False + , createNetworkIPAM = defaultIPAM , createNetworkEnableIPv6 = False + , createNetworkOptions = HM.empty + , createNetworkLabels = [] } instance ToJSON CreateNetworkOpts where - toJSON opts = - object - [ "Name" .= createNetworkName opts - , "CheckDuplicate" .= createNetworkCheckDuplicate opts - , "Driver" .= createNetworkDriver opts - , "Internal" .= createNetworkInternal opts - , "EnableIPv6" .= createNetworkEnableIPv6 opts - ] + toJSON = genericToJSON defaultOptions + { fieldLabelModifier = drop 13, omitNothingFields = True } data NetworkScope = LocalScope | GlobalScope | SwarmScope deriving (Eq, Show) @@ -904,7 +909,7 @@ instance FromJSON NetworkScope where parseJSON "swarm" = return SwarmScope parseJSON _ = fail "Failed to parse NetworkScope" -data CIDR = CIDR Text Int deriving (Eq, Show) +data CIDR = CIDR Text Int deriving (Eq, Show, Generic) instance FromJSON CIDR where parseJSON (JSON.String t) = case T.splitOn "/" t of @@ -916,19 +921,27 @@ instance FromJSON CIDR where _ -> fail "Failed to parse CIDR prefix length" parseJSON _ = fail "Failed to parse CIDR" -data IPAMDriver = DefaultIPAMDriver | NamedIPAMDriver Text deriving (Eq, Show) +instance ToJSON CIDR where + toJSON (CIDR addr pref) = + JSON.String $ T.concat [addr, "/", T.pack $ show pref] + +data IPAMDriver = DefaultIPAMDriver | NamedIPAMDriver Text deriving (Eq, Show, Generic) instance FromJSON IPAMDriver where parseJSON (JSON.String "default") = return DefaultIPAMDriver parseJSON (JSON.String t) = return $ NamedIPAMDriver t parseJSON _ = fail "IPAMDriver is not a string" +instance ToJSON IPAMDriver where + toJSON DefaultIPAMDriver = JSON.String "default" + toJSON (NamedIPAMDriver t) = JSON.String t + data IPAMConfig = IPAMConfig { ipamConfigSubnet :: CIDR , ipamConfigIPRange :: Maybe CIDR - , ipamSubnetGateway :: Maybe Text + , ipamConfigGateway :: Maybe Text , ipamConfigAuxAddress :: Maybe Text - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) instance FromJSON IPAMConfig where parseJSON (JSON.Object o) = IPAMConfig @@ -938,11 +951,15 @@ instance FromJSON IPAMConfig where <*> o .:? "AuxAddress" parseJSON _ = fail "IPAMConfig is not an object" +instance ToJSON IPAMConfig where + toJSON = genericToJSON defaultOptions + { fieldLabelModifier = drop 10, omitNothingFields = True } + data IPAM = IPAM { ipamDriver :: IPAMDriver , ipamConfig :: [IPAMConfig] , ipamOptions :: HM.HashMap Text Text - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) instance FromJSON IPAM where parseJSON (JSON.Object o) = IPAM @@ -951,6 +968,12 @@ instance FromJSON IPAM where <*> o .:? "Options" .!= HM.empty parseJSON _ = fail "IPAM is not an object" +instance ToJSON IPAM where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = drop 4 } + +defaultIPAM :: IPAM +defaultIPAM = IPAM DefaultIPAMDriver [] HM.empty + data NetworkContainer = NetworkContainer { networkContainerName :: ContainerName , networkContainerEndpointID :: Text @@ -980,7 +1003,7 @@ data NetworkDetails = NetworkDetails , networkDetailsIngress :: Bool , networkDetailsIPAM :: IPAM , networkDetailsOptions :: HM.HashMap Text Text - , networkDetailsLabels :: HM.HashMap Text Text + , networkDetailsLabels :: [Label] , networkDetailsContainers :: HM.HashMap Text NetworkContainer } deriving (Eq, Show) @@ -997,7 +1020,7 @@ instance FromJSON NetworkDetails where <*> o .: "Ingress" <*> o .: "IPAM" <*> o .:? "Options" .!= HM.empty - <*> o .:? "Labels" .!= HM.empty + <*> o .:? "Labels" .!= [] <*> o .:? "Containers" .!= HM.empty parseJSON _ = fail "NetworkDetails is not an object" diff --git a/tests/tests.hs b/tests/tests.hs index e167549..9a8a111 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -187,6 +187,21 @@ testDisconnectNetwork = where networkMode (Network mode _) = mode +testPruneNetworks :: IO () +testPruneNetworks = + runDocker $ do + let created = ["n1", "n2", "n3"] + _ <- mapM_ (fromRight <=< createNetwork . opts) created + NetworksDeleted deleted <- fromRight =<< pruneNetworks filter + let remaining = created \\ deleted + when (remaining /= []) $ do + mapM_ (removeNetwork . toNID) remaining + lift . assertFailure $ "pruning networks, networks not pruned: " ++ show remaining + where + toNID = fromJust . toNetworkID + opts n = (defaultCreateNetworkOpts n) {createNetworkLabels = [Label "prune" "me"]} + filter = defaultPruneFilter {pruneFilterIncludeLabels = [("prune", Just "me")]} + testLogDriverOptionsJson :: TestTree testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [test1, test2, test3] where @@ -307,6 +322,7 @@ integrationTests = , testCase "Inspect a network" testInspectNetwork , testCase "Connect a container to a network" testConnectNetwork , testCase "Disconnect a container from a network" testDisconnectNetwork + , testCase "Remove unused networks matching a label" testPruneNetworks ] jsonTests :: TestTree