master...b550387 · docker-hs

git.iko.soy/docker-hs

on b550387 help sign in

src/Docker/Client/Api.hs+24

since splitsnapshots

unifiedsplit

@@ -24,6 +24,11 @@ module Docker.Client.Api (

24 -- * Network

25 , createNetwork

26 , removeNetwork

27+ , listNetworks

28+ , inspectNetwork

29+ , connectNetwork

30+ , disconnectNetwork

31+ , pruneNetworks

27 -- * Other

32 -- * Other

28 , getDockerVersion

33 , getDockerVersion

29 ) where

34 ) where

@@ -225,3 +230,22 @@ createNetwork opts = requestHelper POST (CreateNetworkEndpoint opts) >>= parseR

225removeNetwork :: forall m. (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError ())

230removeNetwork :: forall m. (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError ())

226removeNetwork nid = requestUnit DELETE $ RemoveNetworkEndpoint nid

231removeNetwork nid = requestUnit DELETE $ RemoveNetworkEndpoint nid

227

232

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 =

288 Nothing

289 else

290 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 @@

1module Docker.Client.Internal where

3−import Blaze.ByteString.Builder (toByteString)

3+import Blaze.ByteString.Builder (toByteString)

4−import qualified Data.Aeson as JSON

4+import qualified Data.Aeson as JSON

5−import Data.ByteString (ByteString)

5+import Data.ByteString (ByteString)

6−import qualified Data.ByteString.Char8 as BSC

6+import qualified Data.ByteString.Char8 as BSC

7−import qualified Data.Conduit.Binary as CB

7+import qualified Data.ByteString.Lazy.Char8 as BSLC

8+import qualified Data.Conduit.Binary as CB

8−import qualified Data.Text as T

9+import qualified Data.Text as T

9−import Data.Text.Encoding (decodeUtf8, encodeUtf8)

10+import Data.Text.Encoding (decodeUtf8, encodeUtf8)

10−import qualified Network.HTTP.Client as HTTP

11+import qualified Network.HTTP.Client as HTTP

11−import Network.HTTP.Conduit (requestBodySourceChunked)

12+import Network.HTTP.Conduit (requestBodySourceChunked)

12−import Network.HTTP.Types (Query, encodePath,

13+import Network.HTTP.Types (Query, encodePath,

13− encodePathSegments)

14+ encodePathSegments)

14−import Prelude hiding (all)

15+import Prelude hiding (all)

16import Docker.Client.Types

17import Docker.Client.Types

@@ -78,6 +79,11 @@ getEndpoint v (CreateImageEndpoint name tag _) = encodeURLWithQuery [v, "images"

78getEndpoint v (DeleteImageEndpoint _ cid) = encodeURL [v, "images", fromImageID cid]

79getEndpoint v (DeleteImageEndpoint _ cid) = encodeURL [v, "images", fromImageID cid]

79getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"]

80getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"]

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

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

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

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)]

82getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

88getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

83getEndpointRequestBody VersionEndpoint = Nothing

89getEndpointRequestBody VersionEndpoint = Nothing

@@ -101,8 +107,12 @@ getEndpointRequestBody (DeleteImageEndpoint _ _) = Nothing

101

107

102getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)

108getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)

103getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing

109getEndpointRequestBody (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

104

115

105getEndpointContentType :: Endpoint -> BSC.ByteString

116getEndpointContentType :: Endpoint -> BSC.ByteString

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

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

107getEndpointContentType _ = BSC.pack "application/json; charset=utf-8"

118getEndpointContentType _ = BSC.pack "application/json; charset=utf-8"

108−

src/Docker/Client/Types.hs+272−4

@@ -76,6 +76,27 @@ module Docker.Client.Types (

76 , HostConfig(..)

77 , defaultHostConfig

78 , NetworkingConfig(..)

79+ , NetworkScope(..)

80+ , CIDR(..)

81+ , IPAMDriver(..)

82+ , IPAMConfig(..)

83+ , IPAM(..)

84+ , NetworkContainer(..)

85+ , NetworkDetails(..)

86+ , NetworkType(..)

87+ , NetworkName

88+ , NetworkFilter(..)

89+ , ConnectConfig(..)

90+ , defaultConnectConfig

91+ , DisconnectConfig(..)

92+ , defaultDisconnectConfig

93+ , PruneFilter(..)

94+ , defaultPruneFilter

95+ , NetworksDeleted(..)

96+ , EndpointSettings(..)

97+ , defaultEndpointSettings

98+ , IPAMSettings(..)

99+ , defaultIPAMSettings

79 , EndpointConfig(..)

100 , EndpointConfig(..)

80 , Ulimit(..)

101 , Ulimit(..)

81 , ContainerResources(..)

102 , ContainerResources(..)

@@ -100,6 +121,7 @@ module Docker.Client.Types (

100 , MemoryConstraintSize(..)

121 , MemoryConstraintSize(..)

101 ) where

122 ) where

102

123

124+import Control.Monad (join)

103import Data.Aeson (FromJSON, ToJSON, genericParseJSON,

125import Data.Aeson (FromJSON, ToJSON, genericParseJSON,

104 genericToJSON, object, parseJSON, toJSON,

126 genericToJSON, object, parseJSON, toJSON,

105 (.!=), (.:), (.:?), (.=))

127 (.!=), (.:), (.:?), (.=))

@@ -107,6 +129,7 @@ import qualified Data.Aeson as JSON

107import Data.Aeson.Types (defaultOptions, fieldLabelModifier)

129import Data.Aeson.Types (defaultOptions, fieldLabelModifier)

108import Data.Char (isAlphaNum, toUpper)

130import Data.Char (isAlphaNum, toUpper)

109import qualified Data.HashMap.Strict as HM

131import qualified Data.HashMap.Strict as HM

132+import Data.Maybe (maybeToList, catMaybes)

110import Data.Monoid ((<>))

133import Data.Monoid ((<>))

111import Data.Scientific (floatingOrInteger)

134import Data.Scientific (floatingOrInteger)

112import Data.Text (Text)

135import Data.Text (Text)

@@ -114,6 +137,7 @@ import qualified Data.Text as T

114import Data.Time.Clock (UTCTime)

137import Data.Time.Clock (UTCTime)

115import qualified Data.Vector as V

138import qualified Data.Vector as V

116import GHC.Generics (Generic)

139import GHC.Generics (Generic)

140+import Numeric (readDec)

117import Prelude hiding (all, tail)

141import Prelude hiding (all, tail)

118import Text.Read (readMaybe)

142import Text.Read (readMaybe)

119

143

@@ -139,6 +163,11 @@ data Endpoint =

139 | DeleteImageEndpoint ImageDeleteOpts ImageID

163 | DeleteImageEndpoint ImageDeleteOpts ImageID

140 | CreateNetworkEndpoint CreateNetworkOpts

164 | CreateNetworkEndpoint CreateNetworkOpts

141 | RemoveNetworkEndpoint NetworkID

165 | RemoveNetworkEndpoint NetworkID

166+ | ListNetworksEndpoint [NetworkFilter]

167+ | InspectNetworkEndpoint NetworkID

168+ | ConnectNetworkEndpoint NetworkID ConnectConfig

169+ | DisconnectNetworkEndpoint NetworkID DisconnectConfig

170+ | PruneNetworksEndpoint PruneFilter

142 deriving (Eq, Show)

171 deriving (Eq, Show)

143

172

144-- | We should newtype this

173-- | We should newtype this

@@ -858,6 +887,242 @@ instance ToJSON CreateNetworkOpts where

858 , "EnableIPv6" .= createNetworkEnableIPv6 opts

887 , "EnableIPv6" .= createNetworkEnableIPv6 opts

859 ]

888 ]

860

889

890+data NetworkScope = LocalScope | GlobalScope | SwarmScope deriving (Eq, Show)

891+

892+fromNetworkScope :: NetworkScope -> Text

893+fromNetworkScope LocalScope = "local"

894+fromNetworkScope GlobalScope = "global"

895+fromNetworkScope SwarmScope = "swarm"

896+

897+instance ToJSON NetworkScope where

898+ toJSON = JSON.String . fromNetworkScope

899+

900+instance FromJSON NetworkScope where

901+ parseJSON "local" = return LocalScope

902+ parseJSON "global" = return GlobalScope

903+ parseJSON "swarm" = return SwarmScope

904+ parseJSON _ = fail "Failed to parse NetworkScope"

905+

906+data CIDR = CIDR Text Int deriving (Eq, Show)

907+

908+instance FromJSON CIDR where

909+ parseJSON (JSON.String t) = case T.splitOn "/" t of

910+ [a,p] -> CIDR a <$> parsePrefixLen p

911+ _ -> fail "Failed to parse CIDR"

912+ where

913+ parsePrefixLen p = case readDec (T.unpack p) of

914+ (n,""):_ -> return n

915+ _ -> fail "Failed to parse CIDR prefix length"

916+ parseJSON _ = fail "Failed to parse CIDR"

917+

918+data IPAMDriver = DefaultIPAMDriver | NamedIPAMDriver Text deriving (Eq, Show)

919+

920+instance FromJSON IPAMDriver where

921+ parseJSON (JSON.String "default") = return DefaultIPAMDriver

922+ parseJSON (JSON.String t) = return $ NamedIPAMDriver t

923+ parseJSON _ = fail "IPAMDriver is not a string"

924+

925+data IPAMConfig = IPAMConfig

926+ { ipamConfigSubnet :: CIDR

927+ , ipamConfigIPRange :: Maybe CIDR

928+ , ipamSubnetGateway :: Maybe Text

929+ , ipamConfigAuxAddress :: Maybe Text

930+ } deriving (Eq, Show)

931+

932+instance FromJSON IPAMConfig where

933+ parseJSON (JSON.Object o) = IPAMConfig

934+ <$> o .: "Subnet"

935+ <*> o .:? "IPRange"

936+ <*> o .:? "Gateway"

937+ <*> o .:? "AuxAddress"

938+ parseJSON _ = fail "IPAMConfig is not an object"

939+

940+data IPAM = IPAM

941+ { ipamDriver :: IPAMDriver

942+ , ipamConfig :: [IPAMConfig]

943+ , ipamOptions :: HM.HashMap Text Text

944+ } deriving (Eq, Show)

945+

946+instance FromJSON IPAM where

947+ parseJSON (JSON.Object o) = IPAM

948+ <$> o .:? "Driver" .!= DefaultIPAMDriver

949+ <*> o .:? "Config" .!= []

950+ <*> o .:? "Options" .!= HM.empty

951+ parseJSON _ = fail "IPAM is not an object"

952+

953+data NetworkContainer = NetworkContainer

954+ { networkContainerName :: ContainerName

955+ , networkContainerEndpointID :: Text

956+ , networkContainerMacAddress :: Text

957+ , networkContainerIPv4Address :: Text

958+ , networkContainerIPv6Address :: Text

959+ } deriving (Eq, Show)

960+

961+instance FromJSON NetworkContainer where

962+ parseJSON (JSON.Object o) = NetworkContainer

963+ <$> o .: "Name"

964+ <*> o .: "EndpointID"

965+ <*> o .: "MacAddress"

966+ <*> o .: "IPv4Address"

967+ <*> o .: "IPv6Address"

968+ parseJSON _ = fail "NetworkContainer is not an object"

969+

970+data NetworkDetails = NetworkDetails

971+ { networkDetailsName :: Text

972+ , networkDetailsID :: NetworkID

973+ , networkDetailsCreated :: UTCTime

974+ , networkDetailsScope :: NetworkScope

975+ , networkDetailsDriver :: NetworkMode

976+ , networkDetailsEnableIPv6 :: Bool

977+ , networkDetailsInternal :: Bool

978+ , networkDetailsAttachable :: Bool

979+ , networkDetailsIngress :: Bool

980+ , networkDetailsIPAM :: IPAM

981+ , networkDetailsOptions :: HM.HashMap Text Text

982+ , networkDetailsLabels :: HM.HashMap Text Text

983+ , networkDetailsContainers :: HM.HashMap Text NetworkContainer

984+ } deriving (Eq, Show)

985+

986+instance FromJSON NetworkDetails where

987+ parseJSON v@(JSON.Object o) = NetworkDetails

988+ <$> o .: "Name"

989+ <*> parseJSON v

990+ <*> o .: "Created"

991+ <*> o .: "Scope"

992+ <*> o .: "Driver"

993+ <*> o .: "EnableIPv6"

994+ <*> o .: "Internal"

995+ <*> o .: "Attachable"

996+ <*> o .: "Ingress"

997+ <*> o .: "IPAM"

998+ <*> o .:? "Options" .!= HM.empty

999+ <*> o .:? "Labels" .!= HM.empty

1000+ <*> o .:? "Containers" .!= HM.empty

1001+ parseJSON _ = fail "NetworkDetails is not an object"

1002+

1003+data NetworkType = BuiltinNetwork | CustomNetwork deriving (Eq, Show)

1004+

1005+fromNetworkType :: NetworkType -> Text

1006+fromNetworkType BuiltinNetwork = "builtin"

1007+fromNetworkType CustomNetwork = "custom"

1008+

1009+type NetworkName = Text

1010+

1011+instance ToJSON NetworkType where

1012+ toJSON = JSON.String . fromNetworkType

1013+

1014+instance FromJSON NetworkType where

1015+ parseJSON (JSON.String "builtin") = return BuiltinNetwork

1016+ parseJSON (JSON.String "custom") = return CustomNetwork

1017+ parseJSON _ = fail "Failed to parse NetworkType"

1018+

1019+data NetworkFilter

1020+ = NetworkFilterName Text

1021+ | NetworkFilterID NetworkID

1022+ | NetworkFilterLabel Text

1023+ | NetworkFilterDriver NetworkMode

1024+ | NetworkFilterScope NetworkScope

1025+ | NetworkFilterType NetworkType

1026+ deriving (Eq, Show)

1027+

1028+instance {-# OVERLAPPING #-} ToJSON [NetworkFilter] where

1029+ toJSON = object . fmap toKV

1030+ where

1031+ toKV (NetworkFilterName n) = "name" .= [n]

1032+ toKV (NetworkFilterID i) = "id" .= [fromNetworkID i]

1033+ toKV (NetworkFilterLabel l) = "label" .= [l]

1034+ toKV (NetworkFilterDriver d) = "driver" .= [fromNetworkMode d]

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

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

1037+

1038+data ConnectConfig = ConnectConfig

1039+ { connectContainer :: Text

1040+ , connectEndpointConfig :: EndpointSettings

1041+ } deriving (Eq, Show, Generic)

1042+

1043+instance ToJSON ConnectConfig where

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

1045+

1046+defaultConnectConfig :: Text -> ConnectConfig

1047+defaultConnectConfig = flip ConnectConfig defaultEndpointSettings

1048+

1049+data DisconnectConfig = DisconnectConfig

1050+ { disconnectContainer :: Text

1051+ , disconnectForce :: Bool

1052+ } deriving (Eq, Show, Generic)

1053+

1054+instance ToJSON DisconnectConfig where

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

1056+

1057+defaultDisconnectConfig :: Text -> DisconnectConfig

1058+defaultDisconnectConfig = flip DisconnectConfig False

1059+

1060+data PruneFilter = PruneFilter

1061+ { pruneFilterUntil :: Maybe Text

1062+ -- ^ Can be a Unix timestamp, a date-formatted timestamp, or a duration,

1063+ -- such as @10m@ or @1h30m@.

1064+ , pruneFilterIncludeLabels :: [(Text, (Maybe Text))]

1065+ , pruneFilterExcludeLabels :: [(Text, (Maybe Text))]

1066+ } deriving (Eq, Show)

1067+

1068+instance ToJSON PruneFilter where

1069+ toJSON pf = object . catMaybes $

1070+ [ "until" .=? maybeToList (pruneFilterUntil pf)

1071+ , "label" .=? (constructLabel <$> pruneFilterIncludeLabels pf)

1072+ , "label!" .=? (constructLabel <$> pruneFilterExcludeLabels pf)

1073+ ]

1074+ where

1075+ _ .=? [] = Nothing

1076+ k .=? l = Just $ k .= l

1077+

1078+constructLabel :: (Text, Maybe Text) -> Text

1079+constructLabel (k, Just v) = T.concat [k, "=", v]

1080+constructLabel (k, Nothing) = k

1081+

1082+defaultPruneFilter :: PruneFilter

1083+defaultPruneFilter = PruneFilter Nothing [] []

1084+

1085+newtype NetworksDeleted = NetworksDeleted [Text]

1086+ deriving (Eq, Show)

1087+

1088+instance FromJSON NetworksDeleted where

1089+ parseJSON (JSON.Object o) =

1090+ NetworksDeleted . join . maybeToList <$> o .: "NetworksDeleted"

1091+ parseJSON _ = fail $ "NetworksDeleted is not an object"

1092+

1093+data EndpointSettings = EndpointSettings

1094+ { endpointIPAMConfig :: IPAMSettings

1095+ , endpointLinks :: [Text]

1096+ , endpointAliases :: [Text]

1097+ , endpointNetworkID :: Maybe Text

1098+ , endpointEndpointID :: Maybe Text

1099+ , endpointGateway :: Maybe Text

1100+ , endpointIPAddress :: Maybe Text

1101+ , endpointIPPrefixLen :: Maybe Int

1102+ , endpointIPv6Gateway :: Maybe Text

1103+ , endpointGlobalIPv6Address :: Maybe Text

1104+ , endpointGlobalIPv6PrefixLen :: Maybe Int

1105+ , endpointMacAddress :: Maybe Text

1106+ } deriving (Eq, Show, Generic)

1107+

1108+instance ToJSON EndpointSettings where

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

1110+

1111+defaultEndpointSettings :: EndpointSettings

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

1113+

1114+data IPAMSettings = IPAMSettings

1115+ { ipamIPv4Address :: Maybe Text

1116+ , ipamIPv6Address :: Maybe Text

1117+ , ipamLinkLocalIPs :: [Text]

1118+ } deriving (Eq, Show, Generic)

1119+

1120+instance ToJSON IPAMSettings where

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

1122+

1123+defaultIPAMSettings :: IPAMSettings

1124+defaultIPAMSettings = IPAMSettings Nothing Nothing []

1125+

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

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

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

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

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

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

@@ -1027,11 +1292,14 @@ instance FromJSON NetworkMode where

1027 parseJSON (JSON.String n) = return $ NetworkNamed n

1292 parseJSON (JSON.String n) = return $ NetworkNamed n

1028 parseJSON _ = fail "Unknown NetworkMode"

1293 parseJSON _ = fail "Unknown NetworkMode"

1029

1294

1295+fromNetworkMode :: NetworkMode -> Text

1296+fromNetworkMode NetworkBridge = "bridge"

1297+fromNetworkMode NetworkHost = "host"

1298+fromNetworkMode NetworkDisabled = "none"

1299+fromNetworkMode (NetworkNamed n) = n

1300+

1030instance ToJSON NetworkMode where

1301instance ToJSON NetworkMode where

1031− toJSON NetworkBridge = JSON.String "bridge"

1302+ toJSON = JSON.String . fromNetworkMode

1032− toJSON NetworkHost = JSON.String "host"

1033− toJSON NetworkDisabled = JSON.String "none"

1034− toJSON (NetworkNamed n) = JSON.String n

1035

1303

1036newtype NetworkID = NetworkID Text

1304newtype NetworkID = NetworkID Text

1037 deriving (Eq, Show)

1305 deriving (Eq, Show)

tests/tests.hs+60−1

@@ -11,7 +11,7 @@ import Test.Tasty.QuickCheck (testProperty)

12import Control.Concurrent (threadDelay)

13import Control.Lens ((^.), (^?))

14−import Control.Monad (forM_)

14+import Control.Monad (forM_, when, (<=<))

15import Control.Monad.IO.Class

16import Control.Monad.Trans.Class (lift)

17import qualified Data.Aeson as JSON

@@ -23,6 +23,7 @@ import qualified Data.ByteString.Char8 as C

23import qualified Data.ByteString.Lazy as BL

24import qualified Data.HashMap.Strict as HM

25import Data.Int (Int)

26+import Data.List ((\\))

26import qualified Data.Map as M

27import qualified Data.Map as M

27import Data.Maybe (fromJust, isJust, isNothing, listToMaybe)

28import Data.Maybe (fromJust, isJust, isNothing, listToMaybe)

28import Data.Monoid

29import Data.Monoid

@@ -144,6 +145,48 @@ testCreateRemoveNetwork = do

144 removeStatus <- removeNetwork nid

145 removeStatus <- removeNetwork nid

145 lift $ assertBool ("removing a network, unexpected status: " ++ show removeStatus) $ isRight removeStatus

146 lift $ assertBool ("removing a network, unexpected status: " ++ show removeStatus) $ isRight removeStatus

146

147

148+testListNetworks :: IO ()

149+testListNetworks =

150+ runDocker $ do

151+ res <- listNetworks [NetworkFilterName "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+

147testLogDriverOptionsJson :: TestTree

190testLogDriverOptionsJson :: TestTree

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

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

149 where

192 where

@@ -236,6 +279,17 @@ testNetworkingConfigJson = testGroup "Testing NetworkingConfig JSON" [testSample

236 ]

279 ]

237 ]

280 ]

238

281

282+testDisconnectConfigJson :: TestTree

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

284+ where

285+ testSampleEncode =

286+ let config = DisconnectConfig "mycontainer" True

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

288+ JSON.object

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

290+ , "Force" .= True

291+ ]

292+

239integrationTests :: TestTree

293integrationTests :: TestTree

240integrationTests =

294integrationTests =

241 testGroup

295 testGroup

@@ -249,6 +303,10 @@ integrationTests =

249 , testCase "Run a dummy container with networking and read its log" testRunAndReadLogWithNetworking

303 , testCase "Run a dummy container with networking and read its log" testRunAndReadLogWithNetworking

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

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

251 , testCase "Create and remove a network" testCreateRemoveNetwork

305 , testCase "Create and remove a network" testCreateRemoveNetwork

306+ , testCase "List networks" testListNetworks

307+ , testCase "Inspect a network" testInspectNetwork

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

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

252 ]

310 ]

253

311

254jsonTests :: TestTree

312jsonTests :: TestTree

@@ -262,6 +320,7 @@ jsonTests =

262 , testEntrypointJson

320 , testEntrypointJson

263 , testEnvVarJson

321 , testEnvVarJson

264 , testNetworkingConfigJson

322 , testNetworkingConfigJson

323+ , testDisconnectConfigJson

265 ]

324 ]

266

325

267setup :: IO ()

326setup :: IO ()