on 040f3fa help sign in
6 files changed+495−58
since splitsnapshots
unifiedsplit
.travis.yml+29−24 src/Docker/Client/Api.hs+24 src/Docker/Client/Http.hs+25 src/Docker/Client/Internal.hs+23−13 src/Docker/Client/Types.hs+318−20 tests/tests.hs+76−1
.travis.yml+29−24
@@ -1,11 +1,11 @@
11sudo: required
2−dist: trusty
2+dist: bionic
33
44# Only build master and release tags
5−branches:
6− only:
7− - master
8− - /^v\d+\.\d+(\.\d+)?(-\S*)?$/
5+# branches:
6+# only:
7+# - master
8+# - /^v\d+\.\d+(\.\d+)?(-\S*)?$/
99
1010# Choose a lightweight base image; we provide our own build tools.
1111language:
@@ -27,37 +27,42 @@ env:
2727 - STACK_ARGS=""
2828
2929 matrix:
30− - DOCKER_VERSION="1.12.3-0~trusty" GHCVER=7.10
31− - DOCKER_VERSION="1.13.1-0~ubuntu-trusty" GHCVER=7.10
32− - DOCKER_VERSION="17.05.0~ce-0~ubuntu-trusty" GHCVER=7.10
30+ - DOCKER_VERSION="18.03.1~ce~3-0~ubuntu" GHCVER=7.10
31+ - DOCKER_VERSION="5:18.09.9~3-0~ubuntu-bionic" GHCVER=7.10
32+ - DOCKER_VERSION="5:19.03.6~3-0~ubuntu-bionic" GHCVER=7.10
3333
34− - DOCKER_VERSION="1.12.3-0~trusty" GHCVER=8.0
35− - DOCKER_VERSION="1.13.1-0~ubuntu-trusty" GHCVER=8.0
36− - DOCKER_VERSION="17.05.0~ce-0~ubuntu-trusty" GHCVER=8.0
34+ - DOCKER_VERSION="18.03.1~ce~3-0~ubuntu" GHCVER=8.0
35+ - DOCKER_VERSION="5:18.09.9~3-0~ubuntu-bionic" GHCVER=8.0
36+ - DOCKER_VERSION="5:19.03.6~3-0~ubuntu-bionic" GHCVER=8.0
3737
38− - DOCKER_VERSION="1.12.3-0~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
38+ - DOCKER_VERSION="18.03.1~ce~3-0~ubuntu" GHCVER=8.0.2
39+ - DOCKER_VERSION="5:18.09.9~3-0~ubuntu-bionic" GHCVER=8.0.2
40+ - DOCKER_VERSION="5:19.03.6~3-0~ubuntu-bionic" GHCVER=8.0.2
4141
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
42+ - DOCKER_VERSION="18.03.1~ce~3-0~ubuntu" GHCVER=8.6.4
43+ - DOCKER_VERSION="5:18.09.9~3-0~ubuntu-bionic" GHCVER=8.6.4
44+ - DOCKER_VERSION="5:19.03.6~3-0~ubuntu-bionic" GHCVER=8.6.4
4545
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
46+ - DOCKER_VERSION="18.03.1~ce~3-0~ubuntu" GHCVER=8.8.2
47+ - DOCKER_VERSION="5:18.09.9~3-0~ubuntu-bionic" GHCVER=8.8.2
48+ - DOCKER_VERSION="5:19.03.6~3-0~ubuntu-bionic" GHCVER=8.8.2
4949
5050addons:
5151 apt:
5252 packages:
5353 - libgmp-dev
54+ - apt-transport-https
55+ - ca-certificates
56+ - software-properties-common
57+ - curl
5458
5559before_install:
56− # Upgrade docker to 1.12.3.0
57− - sudo sh -c 'echo "deb https://apt.dockerproject.org/repo ubuntu-trusty main" > /etc/apt/sources.list.d/docker.list'
58− - sudo apt-key adv --keyserver hkp://p80.pool.sks-keyservers.net:80 --recv-keys 58118E89F3A912897C070ADBF76221572C52609D
60+ - curl -fsSL https://download.docker.com/linux/ubuntu/gpg | sudo apt-key add -
61+ - sudo add-apt-repository "deb [arch=amd64] https://download.docker.com/linux/ubuntu $(lsb_release -cs) stable"
5962 - sudo apt-get update
60− - sudo apt-get -qqy -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confold" install docker-engine=$DOCKER_VERSION
63+ - sudo apt-get install -y --no-install-recommends docker-ce=${DOCKER_VERSION}
64+
65+# - sudo apt-get -qqy -o Dpkg::Options::="--force-confdef" -o Dpkg::Options::="--force-confold" install docker-engine=$DOCKER_VERSION
6166
6267install:
6368 - mkdir -p "$HOME"/.local/bin
src/Docker/Client/Api.hs+24
@@ -24,6 +24,11 @@ module Docker.Client.Api (
2424 -- * Network
2525 , createNetwork
2626 , removeNetwork
27+ , listNetworks
28+ , inspectNetwork
29+ , connectNetwork
30+ , disconnectNetwork
31+ , pruneNetworks
2732 -- * Other
2833 , getDockerVersion
2934 ) where
@@ -225,3 +230,22 @@ createNetwork opts = requestHelper POST (CreateNetworkEndpoint opts) >>= parseR
225230removeNetwork :: forall m. (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError ())
226231removeNetwork nid = requestUnit DELETE $ RemoveNetworkEndpoint nid
227232
233+-- | Lists networks optionally matching a list of 'NetworkFilter's.
234+listNetworks :: forall m . (MonadIO m, MonadMask m) => NetworkFilter -> DockerT m (Either DockerError [NetworkDetails])
235+listNetworks nfs = requestHelper GET (ListNetworksEndpoint nfs) >>= parseResponse
236+
237+-- | Gets 'NetworkDetails' for a network, given its name or id.
238+inspectNetwork :: forall m . (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError NetworkDetails)
239+inspectNetwork nid = requestHelper GET (InspectNetworkEndpoint nid) >>= parseResponse
240+
241+-- | Connects a container to a network.
242+connectNetwork :: forall m . (MonadIO m, MonadMask m) => NetworkID -> ConnectConfig -> DockerT m (Either DockerError ())
243+connectNetwork nid cfg = requestUnit POST $ ConnectNetworkEndpoint nid cfg
244+
245+-- | Disconnects a container from a network.
246+disconnectNetwork :: forall m . (MonadIO m, MonadMask m) => NetworkID -> DisconnectConfig -> DockerT m (Either DockerError ())
247+disconnectNetwork nid cfg = requestUnit POST $ DisconnectNetworkEndpoint nid cfg
248+
249+-- | Remove unused networks
250+pruneNetworks :: forall m . (MonadIO m, MonadMask m) => PruneFilter -> DockerT m (Either DockerError NetworksDeleted)
251+pruneNetworks pfs = requestHelper POST (PruneNetworksEndpoint pfs) >>= parseResponse
src/Docker/Client/Http.hs+25
@@ -288,3 +288,28 @@ statusCodeToError (RemoveNetworkEndpoint _) st =
288288 Nothing
289289 else
290290 Just $ DockerInvalidStatusCode st
291+statusCodeToError (ListNetworksEndpoint _) st =
292+ if st == status200 then
293+ Nothing
294+ else
295+ Just $ DockerInvalidStatusCode st
296+statusCodeToError (InspectNetworkEndpoint _) st =
297+ if st == status200 then
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
306+statusCodeToError (DisconnectNetworkEndpoint _ _) st =
307+ if st == status200 then
308+ Nothing
309+ else
310+ Just $ DockerInvalidStatusCode st
311+statusCodeToError (PruneNetworksEndpoint _) st =
312+ if st == status200 then
313+ Nothing
314+ else
315+ Just $ DockerInvalidStatusCode st
src/Docker/Client/Internal.hs+23−13
@@ -1,17 +1,18 @@
11module Docker.Client.Internal where
22
3−import Blaze.ByteString.Builder (toByteString)
4−import qualified Data.Aeson as JSON
5−import Data.ByteString (ByteString)
6−import qualified Data.ByteString.Char8 as BSC
7−import qualified Data.Conduit.Binary as CB
8−import qualified Data.Text as T
9−import Data.Text.Encoding (decodeUtf8, encodeUtf8)
10−import qualified Network.HTTP.Client as HTTP
11−import Network.HTTP.Conduit (requestBodySourceChunked)
12−import Network.HTTP.Types (Query, encodePath,
13− encodePathSegments)
14−import Prelude hiding (all)
3+import Blaze.ByteString.Builder (toByteString)
4+import qualified Data.Aeson as JSON
5+import Data.ByteString (ByteString)
6+import qualified Data.ByteString.Char8 as BSC
7+import qualified Data.ByteString.Lazy.Char8 as BSLC
8+import qualified Data.Conduit.Binary as CB
9+import qualified Data.Text as T
10+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
11+import qualified Network.HTTP.Client as HTTP
12+import Network.HTTP.Conduit (requestBodySourceChunked)
13+import Network.HTTP.Types (Query, encodePath,
14+ encodePathSegments)
15+import Prelude hiding (all)
1516
1617import Docker.Client.Types
1718
@@ -78,6 +79,11 @@ getEndpoint v (CreateImageEndpoint name tag _) = encodeURLWithQuery [v, "images"
7879getEndpoint v (DeleteImageEndpoint _ cid) = encodeURL [v, "images", fromImageID cid]
7980getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"]
8081getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid]
82+getEndpoint v (ListNetworksEndpoint nf) = encodeURLWithQuery [v, "networks"] [("filters", Just . BSLC.toStrict $ JSON.encode nf)]
83+getEndpoint v (InspectNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid]
84+getEndpoint v (ConnectNetworkEndpoint nid _) = encodeURL [v, "networks", fromNetworkID nid, "connect"]
85+getEndpoint v (DisconnectNetworkEndpoint nid _) = encodeURL [v, "networks", fromNetworkID nid, "disconnect"]
86+getEndpoint v (PruneNetworksEndpoint pf) = encodeURLWithQuery [v, "networks", "prune"] [("filters", Just . BSLC.toStrict $ JSON.encode pf)]
8187
8288getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody
8389getEndpointRequestBody VersionEndpoint = Nothing
@@ -101,8 +107,12 @@ getEndpointRequestBody (DeleteImageEndpoint _ _) = Nothing
101107
102108getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)
103109getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing
110+getEndpointRequestBody (ListNetworksEndpoint _) = Nothing
111+getEndpointRequestBody (InspectNetworkEndpoint _) = Nothing
112+getEndpointRequestBody (ConnectNetworkEndpoint _ cfg) = Just $ HTTP.RequestBodyLBS (JSON.encode cfg)
113+getEndpointRequestBody (DisconnectNetworkEndpoint _ cfg) = Just $ HTTP.RequestBodyLBS (JSON.encode cfg)
114+getEndpointRequestBody (PruneNetworksEndpoint _) = Nothing
104115
105116getEndpointContentType :: Endpoint -> BSC.ByteString
106117getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar"
107118getEndpointContentType _ = BSC.pack "application/json; charset=utf-8"
108−
src/Docker/Client/Types.hs+318−20
@@ -76,6 +76,29 @@ module Docker.Client.Types (
7676 , HostConfig(..)
7777 , defaultHostConfig
7878 , NetworkingConfig(..)
79+ , NetworkScope(..)
80+ , CIDR(..)
81+ , IPAMDriver(..)
82+ , IPAMConfig(..)
83+ , IPAM(..)
84+ , defaultIPAM
85+ , NetworkContainer(..)
86+ , NetworkDetails(..)
87+ , NetworkType(..)
88+ , NetworkName
89+ , NetworkFilter(..)
90+ , defaultNetworkFilter
91+ , ConnectConfig(..)
92+ , defaultConnectConfig
93+ , DisconnectConfig(..)
94+ , defaultDisconnectConfig
95+ , PruneFilter(..)
96+ , defaultPruneFilter
97+ , NetworksDeleted(..)
98+ , EndpointSettings(..)
99+ , defaultEndpointSettings
100+ , IPAMSettings(..)
101+ , defaultIPAMSettings
79102 , EndpointConfig(..)
80103 , Ulimit(..)
81104 , ContainerResources(..)
@@ -100,13 +123,15 @@ module Docker.Client.Types (
100123 , MemoryConstraintSize(..)
101124 ) where
102125
126+import Control.Monad (join)
103127import Data.Aeson (FromJSON, ToJSON, genericParseJSON,
104128 genericToJSON, object, parseJSON, toJSON,
105129 (.!=), (.:), (.:?), (.=))
106130import qualified Data.Aeson as JSON
107−import Data.Aeson.Types (defaultOptions, fieldLabelModifier)
131+import Data.Aeson.Types (defaultOptions, fieldLabelModifier, omitNothingFields)
108132import Data.Char (isAlphaNum, toUpper)
109133import qualified Data.HashMap.Strict as HM
134+import Data.Maybe (maybeToList, catMaybes)
110135import Data.Monoid ((<>))
111136import Data.Scientific (floatingOrInteger)
112137import Data.Text (Text)
@@ -114,6 +139,7 @@ import qualified Data.Text as T
114139import Data.Time.Clock (UTCTime)
115140import qualified Data.Vector as V
116141import GHC.Generics (Generic)
142+import Numeric (readDec)
117143import Prelude hiding (all, tail)
118144import Text.Read (readMaybe)
119145
@@ -139,6 +165,11 @@ data Endpoint =
139165 | DeleteImageEndpoint ImageDeleteOpts ImageID
140166 | CreateNetworkEndpoint CreateNetworkOpts
141167 | RemoveNetworkEndpoint NetworkID
168+ | ListNetworksEndpoint NetworkFilter
169+ | InspectNetworkEndpoint NetworkID
170+ | ConnectNetworkEndpoint NetworkID ConnectConfig
171+ | DisconnectNetworkEndpoint NetworkID DisconnectConfig
172+ | PruneNetworksEndpoint PruneFilter
142173 deriving (Eq, Show)
143174
144175-- | We should newtype this
@@ -830,12 +861,17 @@ defaultLogOpts = LogOpts { stdout = True
830861
831862-- | Options for creating a network
832863data 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)
864+ { createNetworkName :: Text -- ^ The network's name
865+ , createNetworkCheckDuplicate :: Bool -- ^ Check for networks with duplicate names.
866+ , createNetworkDriver :: NetworkMode -- ^ Name of the network driver plugin to use.
867+ , createNetworkInternal :: Bool -- ^ Restrict external access to the network.
868+ , createNetworkAttachable :: Bool -- ^ Network is manually attachable in swarm mode.
869+ , createNetworkIngress :: Bool -- ^ Network is a swarm-mode network.
870+ , createNetworkIPAM :: IPAM -- ^ Address management configuration
871+ , createNetworkEnableIPv6 :: Bool -- ^ Enable IPv6 on the network.
872+ , createNetworkOptions :: HM.HashMap Text Text -- ^ Options to pass to the driver.
873+ , createNetworkLabels :: [Label] -- ^ Identifying labels for the network.
874+ } deriving (Eq, Show, Generic)
839875
840876-- | Sensible defalut for create network options
841877defaultCreateNetworkOpts :: Text -> CreateNetworkOpts
@@ -843,20 +879,279 @@ defaultCreateNetworkOpts name =
843879 CreateNetworkOpts
844880 { createNetworkName = name
845881 , createNetworkCheckDuplicate = False
846− , createNetworkDriver = "bridge"
882+ , createNetworkDriver = NetworkBridge
847883 , createNetworkInternal = True
884+ , createNetworkAttachable = False
885+ , createNetworkIngress = False
886+ , createNetworkIPAM = defaultIPAM
848887 , createNetworkEnableIPv6 = False
888+ , createNetworkOptions = HM.empty
889+ , createNetworkLabels = []
849890 }
850891
851892instance 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− ]
893+ toJSON = genericToJSON defaultOptions
894+ { fieldLabelModifier = drop 13, omitNothingFields = True }
895+
896+data NetworkScope = LocalScope | GlobalScope | SwarmScope deriving (Eq, Show)
897+
898+fromNetworkScope :: NetworkScope -> Text
899+fromNetworkScope LocalScope = "local"
900+fromNetworkScope GlobalScope = "global"
901+fromNetworkScope SwarmScope = "swarm"
902+
903+instance ToJSON NetworkScope where
904+ toJSON = JSON.String . fromNetworkScope
905+
906+instance FromJSON NetworkScope where
907+ parseJSON "local" = return LocalScope
908+ parseJSON "global" = return GlobalScope
909+ parseJSON "swarm" = return SwarmScope
910+ parseJSON _ = fail "Failed to parse NetworkScope"
911+
912+data CIDR = CIDR Text Int deriving (Eq, Show, Generic)
913+
914+instance FromJSON CIDR where
915+ parseJSON (JSON.String t) = case T.splitOn "/" t of
916+ [a,p] -> CIDR a <$> parsePrefixLen p
917+ _ -> fail "Failed to parse CIDR"
918+ where
919+ parsePrefixLen p = case readDec (T.unpack p) of
920+ (n,""):_ -> return n
921+ _ -> fail "Failed to parse CIDR prefix length"
922+ parseJSON _ = fail "Failed to parse CIDR"
923+
924+instance ToJSON CIDR where
925+ toJSON (CIDR addr pref) =
926+ JSON.String $ T.concat [addr, "/", T.pack $ show pref]
927+
928+data IPAMDriver = DefaultIPAMDriver | NamedIPAMDriver Text deriving (Eq, Show, Generic)
929+
930+instance FromJSON IPAMDriver where
931+ parseJSON (JSON.String "default") = return DefaultIPAMDriver
932+ parseJSON (JSON.String t) = return $ NamedIPAMDriver t
933+ parseJSON _ = fail "IPAMDriver is not a string"
934+
935+instance ToJSON IPAMDriver where
936+ toJSON DefaultIPAMDriver = JSON.String "default"
937+ toJSON (NamedIPAMDriver t) = JSON.String t
938+
939+data IPAMConfig = IPAMConfig
940+ { ipamConfigSubnet :: CIDR
941+ , ipamConfigIPRange :: Maybe CIDR
942+ , ipamConfigGateway :: Maybe Text
943+ , ipamConfigAuxAddress :: Maybe Text
944+ } deriving (Eq, Show, Generic)
945+
946+instance FromJSON IPAMConfig where
947+ parseJSON (JSON.Object o) = IPAMConfig
948+ <$> o .: "Subnet"
949+ <*> o .:? "IPRange"
950+ <*> o .:? "Gateway"
951+ <*> o .:? "AuxAddress"
952+ parseJSON _ = fail "IPAMConfig is not an object"
953+
954+instance ToJSON IPAMConfig where
955+ toJSON = genericToJSON defaultOptions
956+ { fieldLabelModifier = drop 10, omitNothingFields = True }
957+
958+data IPAM = IPAM
959+ { ipamDriver :: IPAMDriver
960+ , ipamConfig :: [IPAMConfig]
961+ , ipamOptions :: HM.HashMap Text Text
962+ } deriving (Eq, Show, Generic)
963+
964+instance FromJSON IPAM where
965+ parseJSON (JSON.Object o) = IPAM
966+ <$> o .:? "Driver" .!= DefaultIPAMDriver
967+ <*> o .:? "Config" .!= []
968+ <*> o .:? "Options" .!= HM.empty
969+ parseJSON _ = fail "IPAM is not an object"
970+
971+instance ToJSON IPAM where
972+ toJSON = genericToJSON defaultOptions { fieldLabelModifier = drop 4 }
973+
974+defaultIPAM :: IPAM
975+defaultIPAM = IPAM DefaultIPAMDriver [] HM.empty
976+
977+data NetworkContainer = NetworkContainer
978+ { networkContainerName :: ContainerName
979+ , networkContainerEndpointID :: Text
980+ , networkContainerMacAddress :: Text
981+ , networkContainerIPv4Address :: Text
982+ , networkContainerIPv6Address :: Text
983+ } deriving (Eq, Show)
984+
985+instance FromJSON NetworkContainer where
986+ parseJSON (JSON.Object o) = NetworkContainer
987+ <$> o .: "Name"
988+ <*> o .: "EndpointID"
989+ <*> o .: "MacAddress"
990+ <*> o .: "IPv4Address"
991+ <*> o .: "IPv6Address"
992+ parseJSON _ = fail "NetworkContainer is not an object"
993+
994+data NetworkDetails = NetworkDetails
995+ { networkDetailsName :: Text
996+ , networkDetailsID :: NetworkID
997+ , networkDetailsCreated :: UTCTime
998+ , networkDetailsScope :: NetworkScope
999+ , networkDetailsDriver :: NetworkMode
1000+ , networkDetailsEnableIPv6 :: Bool
1001+ , networkDetailsInternal :: Bool
1002+ , networkDetailsAttachable :: Bool
1003+ , networkDetailsIngress :: Bool
1004+ , networkDetailsIPAM :: IPAM
1005+ , networkDetailsOptions :: HM.HashMap Text Text
1006+ , networkDetailsLabels :: [Label]
1007+ , networkDetailsContainers :: HM.HashMap Text NetworkContainer
1008+ } deriving (Eq, Show)
1009+
1010+instance FromJSON NetworkDetails where
1011+ parseJSON v@(JSON.Object o) = NetworkDetails
1012+ <$> o .: "Name"
1013+ <*> parseJSON v
1014+ <*> o .: "Created"
1015+ <*> o .: "Scope"
1016+ <*> o .: "Driver"
1017+ <*> o .: "EnableIPv6"
1018+ <*> o .: "Internal"
1019+ <*> o .: "Attachable"
1020+ <*> o .: "Ingress"
1021+ <*> o .: "IPAM"
1022+ <*> o .:? "Options" .!= HM.empty
1023+ <*> o .:? "Labels" .!= []
1024+ <*> o .:? "Containers" .!= HM.empty
1025+ parseJSON _ = fail "NetworkDetails is not an object"
1026+
1027+data NetworkType = BuiltinNetwork | CustomNetwork deriving (Eq, Show)
1028+
1029+fromNetworkType :: NetworkType -> Text
1030+fromNetworkType BuiltinNetwork = "builtin"
1031+fromNetworkType CustomNetwork = "custom"
1032+
1033+type NetworkName = Text
1034+
1035+instance ToJSON NetworkType where
1036+ toJSON = JSON.String . fromNetworkType
1037+
1038+instance FromJSON NetworkType where
1039+ parseJSON (JSON.String "builtin") = return BuiltinNetwork
1040+ parseJSON (JSON.String "custom") = return CustomNetwork
1041+ parseJSON _ = fail "Failed to parse NetworkType"
1042+
1043+data NetworkFilter = NetworkFilter
1044+ { networkFilterNames :: [Text]
1045+ , networkFilterIDs :: [NetworkID]
1046+ , networkFilterDrivers :: [NetworkMode]
1047+ , networkFilterScopes :: [NetworkScope]
1048+ , networkFilterTypes :: [NetworkType]
1049+ , networkFilterLabels :: [(Text, (Maybe Text))]
1050+ } deriving (Eq, Show)
1051+
1052+instance ToJSON NetworkFilter where
1053+ toJSON nf = object . catMaybes $
1054+ [ "name" .=? networkFilterNames nf
1055+ , "id" .=? (fromNetworkID <$> networkFilterIDs nf)
1056+ , "driver" .=? (fromNetworkMode <$> networkFilterDrivers nf)
1057+ , "scope" .=? (fromNetworkScope <$> networkFilterScopes nf)
1058+ , "type" .=? (fromNetworkType <$> networkFilterTypes nf)
1059+ , "label" .=? (constructLabel <$> networkFilterLabels nf)
1060+ ]
1061+ where
1062+ _ .=? [] = Nothing
1063+ k .=? l = Just $ k .= l
1064+
1065+constructLabel :: (Text, Maybe Text) -> Text
1066+constructLabel (k, Just v) = T.concat [k, "=", v]
1067+constructLabel (k, Nothing) = k
1068+
1069+defaultNetworkFilter :: NetworkFilter
1070+defaultNetworkFilter = NetworkFilter [] [] [] [] [] []
1071+
1072+data ConnectConfig = ConnectConfig
1073+ { connectContainer :: Text
1074+ , connectEndpointConfig :: EndpointSettings
1075+ } deriving (Eq, Show, Generic)
1076+
1077+instance ToJSON ConnectConfig where
1078+ toJSON = genericToJSON defaultOptions { fieldLabelModifier = drop 7 }
1079+
1080+defaultConnectConfig :: Text -> ConnectConfig
1081+defaultConnectConfig = flip ConnectConfig defaultEndpointSettings
1082+
1083+data DisconnectConfig = DisconnectConfig
1084+ { disconnectContainer :: Text
1085+ , disconnectForce :: Bool
1086+ } deriving (Eq, Show, Generic)
1087+
1088+instance ToJSON DisconnectConfig where
1089+ toJSON = genericToJSON defaultOptions { fieldLabelModifier = drop 10 }
1090+
1091+defaultDisconnectConfig :: Text -> DisconnectConfig
1092+defaultDisconnectConfig = flip DisconnectConfig False
1093+
1094+data PruneFilter = PruneFilter
1095+ { pruneFilterUntil :: Maybe Text
1096+ -- ^ Can be a Unix timestamp, a date-formatted timestamp, or a duration,
1097+ -- such as @10m@ or @1h30m@.
1098+ , pruneFilterIncludeLabels :: [(Text, (Maybe Text))]
1099+ , pruneFilterExcludeLabels :: [(Text, (Maybe Text))]
1100+ } deriving (Eq, Show)
1101+
1102+instance ToJSON PruneFilter where
1103+ toJSON pf = object . catMaybes $
1104+ [ "until" .=? maybeToList (pruneFilterUntil pf)
1105+ , "label" .=? (constructLabel <$> pruneFilterIncludeLabels pf)
1106+ , "label!" .=? (constructLabel <$> pruneFilterExcludeLabels pf)
1107+ ]
1108+ where
1109+ _ .=? [] = Nothing
1110+ k .=? l = Just $ k .= l
1111+
1112+defaultPruneFilter :: PruneFilter
1113+defaultPruneFilter = PruneFilter Nothing [] []
1114+
1115+newtype NetworksDeleted = NetworksDeleted [Text]
1116+ deriving (Eq, Show)
1117+
1118+instance FromJSON NetworksDeleted where
1119+ parseJSON (JSON.Object o) =
1120+ NetworksDeleted . join . maybeToList <$> o .: "NetworksDeleted"
1121+ parseJSON _ = fail $ "NetworksDeleted is not an object"
1122+
1123+data EndpointSettings = EndpointSettings
1124+ { endpointIPAMConfig :: IPAMSettings
1125+ , endpointLinks :: [Text]
1126+ , endpointAliases :: [Text]
1127+ , endpointNetworkID :: Maybe Text
1128+ , endpointEndpointID :: Maybe Text
1129+ , endpointGateway :: Maybe Text
1130+ , endpointIPAddress :: Maybe Text
1131+ , endpointIPPrefixLen :: Maybe Int
1132+ , endpointIPv6Gateway :: Maybe Text
1133+ , endpointGlobalIPv6Address :: Maybe Text
1134+ , endpointGlobalIPv6PrefixLen :: Maybe Int
1135+ , endpointMacAddress :: Maybe Text
1136+ } deriving (Eq, Show, Generic)
1137+
1138+instance ToJSON EndpointSettings where
1139+ toJSON = genericToJSON defaultOptions { fieldLabelModifier = drop 8 }
1140+
1141+defaultEndpointSettings :: EndpointSettings
1142+defaultEndpointSettings = EndpointSettings defaultIPAMSettings [] [] Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
1143+
1144+data IPAMSettings = IPAMSettings
1145+ { ipamIPv4Address :: Maybe Text
1146+ , ipamIPv6Address :: Maybe Text
1147+ , ipamLinkLocalIPs :: [Text]
1148+ } deriving (Eq, Show, Generic)
1149+
1150+instance ToJSON IPAMSettings where
1151+ toJSON = genericToJSON defaultOptions { fieldLabelModifier = drop 4 }
1152+
1153+defaultIPAMSettings :: IPAMSettings
1154+defaultIPAMSettings = IPAMSettings Nothing Nothing []
8601155
8611156-- TOOD: Add support for SELinux Volume labels (eg. "ro,z" or "ro/Z")
8621157-- | Set permissions on volumes that you mount in the container.
@@ -1027,11 +1322,14 @@ instance FromJSON NetworkMode where
10271322 parseJSON (JSON.String n) = return $ NetworkNamed n
10281323 parseJSON _ = fail "Unknown NetworkMode"
10291324
1325+fromNetworkMode :: NetworkMode -> Text
1326+fromNetworkMode NetworkBridge = "bridge"
1327+fromNetworkMode NetworkHost = "host"
1328+fromNetworkMode NetworkDisabled = "none"
1329+fromNetworkMode (NetworkNamed n) = n
1330+
10301331instance ToJSON NetworkMode where
1031− toJSON NetworkBridge = JSON.String "bridge"
1032− toJSON NetworkHost = JSON.String "host"
1033− toJSON NetworkDisabled = JSON.String "none"
1034− toJSON (NetworkNamed n) = JSON.String n
1332+ toJSON = JSON.String . fromNetworkMode
10351333
10361334newtype NetworkID = NetworkID Text
10371335 deriving (Eq, Show)
tests/tests.hs+76−1
@@ -11,7 +11,7 @@ import Test.Tasty.QuickCheck (testProperty)
1111
1212import Control.Concurrent (threadDelay)
1313import Control.Lens ((^.), (^?))
14−import Control.Monad (forM_)
14+import Control.Monad (forM_, when, (<=<))
1515import Control.Monad.IO.Class
1616import Control.Monad.Trans.Class (lift)
1717import qualified Data.Aeson as JSON
@@ -23,6 +23,7 @@ import qualified Data.ByteString.Char8 as C
2323import qualified Data.ByteString.Lazy as BL
2424import qualified Data.HashMap.Strict as HM
2525import Data.Int (Int)
26+import Data.List ((\\))
2627import qualified Data.Map as M
2728import Data.Maybe (fromJust, isJust, isNothing, listToMaybe)
2829import Data.Monoid
@@ -144,6 +145,63 @@ testCreateRemoveNetwork = do
144145 removeStatus <- removeNetwork nid
145146 lift $ assertBool ("removing a network, unexpected status: " ++ show removeStatus) $ isRight removeStatus
146147
148+testListNetworks :: IO ()
149+testListNetworks =
150+ runDocker $ do
151+ res <- listNetworks defaultNetworkFilter {networkFilterNames = ["bridge"]}
152+ lift $ case res of
153+ Left _ -> assertFailure $ "listing networks, unexpected status: " ++ show res
154+ Right (d:_) -> assertBool "listing networks, bridge network missing" $ networkDetailsName d == "bridge"
155+
156+testInspectNetwork :: IO ()
157+testInspectNetwork =
158+ runDocker $ do
159+ res <- inspectNetwork . fromJust $ toNetworkID "bridge"
160+ lift $ assertBool ("inspecting networks, unexpected status: " ++ show res) $ isRight res
161+
162+testConnectNetwork :: IO ()
163+testConnectNetwork =
164+ runDocker $ do
165+ containerId <- fromRight =<< createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing
166+ networkId <- fromRight =<< createNetwork (defaultCreateNetworkOpts "mynetwork")
167+ res <- connectNetwork networkId . defaultConnectConfig $ fromContainerID containerId
168+ lift $ assertBool ("connecting network, unexpected status: " ++ show res) $ isRight res
169+ details <- fromRight =<< inspectContainer containerId
170+ _ <- deleteContainer defaultContainerDeleteOpts containerId
171+ _ <- removeNetwork networkId
172+ let networks = networkMode <$> (networkSettingsNetworks . networkSettings) details
173+ lift $ assertBool "connecting network failed" $ NetworkNamed "mynetwork" `elem` networks
174+ where
175+ networkMode (Network mode _) = mode
176+
177+testDisconnectNetwork :: IO ()
178+testDisconnectNetwork =
179+ runDocker $ do
180+ containerId <- fromRight =<< createContainer (defaultCreateOpts (testImageName <> ":latest")) Nothing
181+ res <- disconnectNetwork (fromJust $ toNetworkID "bridge") (defaultDisconnectConfig $ fromContainerID containerId)
182+ lift $ assertBool ("disconnecting network, unexpected status: " ++ show res) $ isRight res
183+ details <- fromRight =<< inspectContainer containerId
184+ _ <- deleteContainer defaultContainerDeleteOpts containerId
185+ let networks = networkMode <$> (networkSettingsNetworks . networkSettings) details
186+ lift $ assertBool "disconnecting network failed" $ null networks
187+ where
188+ networkMode (Network mode _) = mode
189+
190+testPruneNetworks :: IO ()
191+testPruneNetworks =
192+ runDocker $ do
193+ let created = ["n1", "n2", "n3"]
194+ _ <- mapM_ (fromRight <=< createNetwork . opts) created
195+ NetworksDeleted deleted <- fromRight =<< pruneNetworks filter
196+ let remaining = created \\ deleted
197+ when (remaining /= []) $ do
198+ mapM_ (removeNetwork . toNID) remaining
199+ lift . assertFailure $ "pruning networks, networks not pruned: " ++ show remaining
200+ where
201+ toNID = fromJust . toNetworkID
202+ opts n = (defaultCreateNetworkOpts n) {createNetworkLabels = [Label "prune" "me"]}
203+ filter = defaultPruneFilter {pruneFilterIncludeLabels = [("prune", Just "me")]}
204+
147205testLogDriverOptionsJson :: TestTree
148206testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [test1, test2, test3]
149207 where
@@ -236,6 +294,17 @@ testNetworkingConfigJson = testGroup "Testing NetworkingConfig JSON" [testSample
236294 ]
237295 ]
238296
297+testDisconnectConfigJson :: TestTree
298+testDisconnectConfigJson = testGroup "Testing DisconnectConfig JSON" [testSampleEncode]
299+ where
300+ testSampleEncode =
301+ let config = DisconnectConfig "mycontainer" True
302+ in testCase "Test toJSON" $ assert $ JSON.toJSON config ==
303+ JSON.object
304+ [ "Container" .= ("mycontainer" :: Text)
305+ , "Force" .= True
306+ ]
307+
239308integrationTests :: TestTree
240309integrationTests =
241310 testGroup
@@ -249,6 +318,11 @@ integrationTests =
249318 , testCase "Run a dummy container with networking and read its log" testRunAndReadLogWithNetworking
250319 , testCase "Try to stop a container that doesn't exist" testStopNonexisting
251320 , testCase "Create and remove a network" testCreateRemoveNetwork
321+ , testCase "List networks" testListNetworks
322+ , testCase "Inspect a network" testInspectNetwork
323+ , testCase "Connect a container to a network" testConnectNetwork
324+ , testCase "Disconnect a container from a network" testDisconnectNetwork
325+ , testCase "Remove unused networks matching a label" testPruneNetworks
252326 ]
253327
254328jsonTests :: TestTree
@@ -262,6 +336,7 @@ jsonTests =
262336 , testEntrypointJson
263337 , testEnvVarJson
264338 , testNetworkingConfigJson
339+ , testDisconnectConfigJson
265340 ]
266341
267342setup :: IO ()