master...af843a1 · docker-hs

git.iko.soy/docker-hs

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

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+279−4

@@ -76,6 +76,28 @@ 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+ , defaultNetworkFilter

90+ , ConnectConfig(..)

91+ , defaultConnectConfig

92+ , DisconnectConfig(..)

93+ , defaultDisconnectConfig

94+ , PruneFilter(..)

95+ , defaultPruneFilter

96+ , NetworksDeleted(..)

97+ , EndpointSettings(..)

98+ , defaultEndpointSettings

99+ , IPAMSettings(..)

100+ , defaultIPAMSettings

79 , EndpointConfig(..)

101 , EndpointConfig(..)

80 , Ulimit(..)

102 , Ulimit(..)

81 , ContainerResources(..)

103 , ContainerResources(..)

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

100 , MemoryConstraintSize(..)

122 , MemoryConstraintSize(..)

101 ) where

123 ) where

102

124

125+import Control.Monad (join)

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

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

104 genericToJSON, object, parseJSON, toJSON,

127 genericToJSON, object, parseJSON, toJSON,

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

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

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

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

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

108import Data.Char (isAlphaNum, toUpper)

131import Data.Char (isAlphaNum, toUpper)

109import qualified Data.HashMap.Strict as HM

132import qualified Data.HashMap.Strict as HM

133+import Data.Maybe (maybeToList, catMaybes)

110import Data.Monoid ((<>))

134import Data.Monoid ((<>))

111import Data.Scientific (floatingOrInteger)

135import Data.Scientific (floatingOrInteger)

112import Data.Text (Text)

136import Data.Text (Text)

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

114import Data.Time.Clock (UTCTime)

138import Data.Time.Clock (UTCTime)

115import qualified Data.Vector as V

139import qualified Data.Vector as V

116import GHC.Generics (Generic)

140import GHC.Generics (Generic)

141+import Numeric (readDec)

117import Prelude hiding (all, tail)

142import Prelude hiding (all, tail)

118import Text.Read (readMaybe)

143import Text.Read (readMaybe)

119

144

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

139 | DeleteImageEndpoint ImageDeleteOpts ImageID

164 | DeleteImageEndpoint ImageDeleteOpts ImageID

140 | CreateNetworkEndpoint CreateNetworkOpts

165 | CreateNetworkEndpoint CreateNetworkOpts

141 | RemoveNetworkEndpoint NetworkID

166 | RemoveNetworkEndpoint NetworkID

167+ | ListNetworksEndpoint NetworkFilter

168+ | InspectNetworkEndpoint NetworkID

169+ | ConnectNetworkEndpoint NetworkID ConnectConfig

170+ | DisconnectNetworkEndpoint NetworkID DisconnectConfig

171+ | PruneNetworksEndpoint PruneFilter

142 deriving (Eq, Show)

172 deriving (Eq, Show)

143

173

144-- | We should newtype this

174-- | We should newtype this

@@ -858,6 +888,248 @@ instance ToJSON CreateNetworkOpts where

858 , "EnableIPv6" .= createNetworkEnableIPv6 opts

888 , "EnableIPv6" .= createNetworkEnableIPv6 opts

859 ]

889 ]

860

890

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

892+

893+fromNetworkScope :: NetworkScope -> Text

894+fromNetworkScope LocalScope = "local"

895+fromNetworkScope GlobalScope = "global"

896+fromNetworkScope SwarmScope = "swarm"

897+

898+instance ToJSON NetworkScope where

899+ toJSON = JSON.String . fromNetworkScope

900+

901+instance FromJSON NetworkScope where

902+ parseJSON "local" = return LocalScope

903+ parseJSON "global" = return GlobalScope

904+ parseJSON "swarm" = return SwarmScope

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

906+

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

908+

909+instance FromJSON CIDR where

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

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

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

913+ where

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

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

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

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

918+

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

920+

921+instance FromJSON IPAMDriver where

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

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

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

925+

926+data IPAMConfig = IPAMConfig

927+ { ipamConfigSubnet :: CIDR

928+ , ipamConfigIPRange :: Maybe CIDR

929+ , ipamSubnetGateway :: Maybe Text

930+ , ipamConfigAuxAddress :: Maybe Text

931+ } deriving (Eq, Show)

932+

933+instance FromJSON IPAMConfig where

934+ parseJSON (JSON.Object o) = IPAMConfig

935+ <$> o .: "Subnet"

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

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

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

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

940+

941+data IPAM = IPAM

942+ { ipamDriver :: IPAMDriver

943+ , ipamConfig :: [IPAMConfig]

944+ , ipamOptions :: HM.HashMap Text Text

945+ } deriving (Eq, Show)

946+

947+instance FromJSON IPAM where

948+ parseJSON (JSON.Object o) = IPAM

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

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

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

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

953+

954+data NetworkContainer = NetworkContainer

955+ { networkContainerName :: ContainerName

956+ , networkContainerEndpointID :: Text

957+ , networkContainerMacAddress :: Text

958+ , networkContainerIPv4Address :: Text

959+ , networkContainerIPv6Address :: Text

960+ } deriving (Eq, Show)

961+

962+instance FromJSON NetworkContainer where

963+ parseJSON (JSON.Object o) = NetworkContainer

964+ <$> o .: "Name"

965+ <*> o .: "EndpointID"

966+ <*> o .: "MacAddress"

967+ <*> o .: "IPv4Address"

968+ <*> o .: "IPv6Address"

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

970+

971+data NetworkDetails = NetworkDetails

972+ { networkDetailsName :: Text

973+ , networkDetailsID :: NetworkID

974+ , networkDetailsCreated :: UTCTime

975+ , networkDetailsScope :: NetworkScope

976+ , networkDetailsDriver :: NetworkMode

977+ , networkDetailsEnableIPv6 :: Bool

978+ , networkDetailsInternal :: Bool

979+ , networkDetailsAttachable :: Bool

980+ , networkDetailsIngress :: Bool

981+ , networkDetailsIPAM :: IPAM

982+ , networkDetailsOptions :: HM.HashMap Text Text

983+ , networkDetailsLabels :: HM.HashMap Text Text

984+ , networkDetailsContainers :: HM.HashMap Text NetworkContainer

985+ } deriving (Eq, Show)

986+

987+instance FromJSON NetworkDetails where

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

989+ <$> o .: "Name"

990+ <*> parseJSON v

991+ <*> o .: "Created"

992+ <*> o .: "Scope"

993+ <*> o .: "Driver"

994+ <*> o .: "EnableIPv6"

995+ <*> o .: "Internal"

996+ <*> o .: "Attachable"

997+ <*> o .: "Ingress"

998+ <*> o .: "IPAM"

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

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

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

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

1003+

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

1005+

1006+fromNetworkType :: NetworkType -> Text

1007+fromNetworkType BuiltinNetwork = "builtin"

1008+fromNetworkType CustomNetwork = "custom"

1009+

1010+type NetworkName = Text

1011+

1012+instance ToJSON NetworkType where

1013+ toJSON = JSON.String . fromNetworkType

1014+

1015+instance FromJSON NetworkType where

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

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

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

1019+

1020+data NetworkFilter = NetworkFilter

1021+ { networkFilterNames :: [Text]

1022+ , networkFilterIDs :: [NetworkID]

1023+ , networkFilterDrivers :: [NetworkMode]

1024+ , networkFilterScopes :: [NetworkScope]

1025+ , networkFilterTypes :: [NetworkType]

1026+ , networkFilterLabels :: [(Text, (Maybe Text))]

1027+ } deriving (Eq, Show)

1028+

1029+instance ToJSON NetworkFilter where

1030+ toJSON nf = object . catMaybes $

1031+ [ "name" .=? networkFilterNames nf

1032+ , "id" .=? (fromNetworkID <$> networkFilterIDs nf)

1033+ , "driver" .=? (fromNetworkMode <$> networkFilterDrivers nf)

1034+ , "scope" .=? (fromNetworkScope <$> networkFilterScopes nf)

1035+ , "type" .=? (fromNetworkType <$> networkFilterTypes nf)

1036+ , "label" .=? (constructLabel <$> networkFilterLabels nf)

1037+ ]

1038+ where

1039+ _ .=? [] = Nothing

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

1041+

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

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

1044+constructLabel (k, Nothing) = k

1045+

1046+defaultNetworkFilter :: NetworkFilter

1047+defaultNetworkFilter = NetworkFilter [] [] [] [] [] []

1048+

1049+data ConnectConfig = ConnectConfig

1050+ { connectContainer :: Text

1051+ , connectEndpointConfig :: EndpointSettings

1052+ } deriving (Eq, Show, Generic)

1053+

1054+instance ToJSON ConnectConfig where

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

1056+

1057+defaultConnectConfig :: Text -> ConnectConfig

1058+defaultConnectConfig = flip ConnectConfig defaultEndpointSettings

1059+

1060+data DisconnectConfig = DisconnectConfig

1061+ { disconnectContainer :: Text

1062+ , disconnectForce :: Bool

1063+ } deriving (Eq, Show, Generic)

1064+

1065+instance ToJSON DisconnectConfig where

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

1067+

1068+defaultDisconnectConfig :: Text -> DisconnectConfig

1069+defaultDisconnectConfig = flip DisconnectConfig False

1070+

1071+data PruneFilter = PruneFilter

1072+ { pruneFilterUntil :: Maybe Text

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

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

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

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

1077+ } deriving (Eq, Show)

1078+

1079+instance ToJSON PruneFilter where

1080+ toJSON pf = object . catMaybes $

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

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

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

1084+ ]

1085+ where

1086+ _ .=? [] = Nothing

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

1088+

1089+defaultPruneFilter :: PruneFilter

1090+defaultPruneFilter = PruneFilter Nothing [] []

1091+

1092+newtype NetworksDeleted = NetworksDeleted [Text]

1093+ deriving (Eq, Show)

1094+

1095+instance FromJSON NetworksDeleted where

1096+ parseJSON (JSON.Object o) =

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

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

1099+

1100+data EndpointSettings = EndpointSettings

1101+ { endpointIPAMConfig :: IPAMSettings

1102+ , endpointLinks :: [Text]

1103+ , endpointAliases :: [Text]

1104+ , endpointNetworkID :: Maybe Text

1105+ , endpointEndpointID :: Maybe Text

1106+ , endpointGateway :: Maybe Text

1107+ , endpointIPAddress :: Maybe Text

1108+ , endpointIPPrefixLen :: Maybe Int

1109+ , endpointIPv6Gateway :: Maybe Text

1110+ , endpointGlobalIPv6Address :: Maybe Text

1111+ , endpointGlobalIPv6PrefixLen :: Maybe Int

1112+ , endpointMacAddress :: Maybe Text

1113+ } deriving (Eq, Show, Generic)

1114+

1115+instance ToJSON EndpointSettings where

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

1117+

1118+defaultEndpointSettings :: EndpointSettings

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

1120+

1121+data IPAMSettings = IPAMSettings

1122+ { ipamIPv4Address :: Maybe Text

1123+ , ipamIPv6Address :: Maybe Text

1124+ , ipamLinkLocalIPs :: [Text]

1125+ } deriving (Eq, Show, Generic)

1126+

1127+instance ToJSON IPAMSettings where

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

1129+

1130+defaultIPAMSettings :: IPAMSettings

1131+defaultIPAMSettings = IPAMSettings Nothing Nothing []

1132+

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

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

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

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

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

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

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

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

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

1028 parseJSON _ = fail "Unknown NetworkMode"

1300 parseJSON _ = fail "Unknown NetworkMode"

1029

1301

1302+fromNetworkMode :: NetworkMode -> Text

1303+fromNetworkMode NetworkBridge = "bridge"

1304+fromNetworkMode NetworkHost = "host"

1305+fromNetworkMode NetworkDisabled = "none"

1306+fromNetworkMode (NetworkNamed n) = n

1307+

1030instance ToJSON NetworkMode where

1308instance ToJSON NetworkMode where

1031− toJSON NetworkBridge = JSON.String "bridge"

1309+ toJSON = JSON.String . fromNetworkMode

1032− toJSON NetworkHost = JSON.String "host"

1033− toJSON NetworkDisabled = JSON.String "none"

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

1035

1310

1036newtype NetworkID = NetworkID Text

1311newtype NetworkID = NetworkID Text

1037 deriving (Eq, Show)

1312 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 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+

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