84732d3 · docker-hs · git.iko.soy

git.iko.soy/docker-hs

on master help sign in

Implement create and remove network API

84732d3Alex K8 years ago

src/Docker/Client/Api.hs+11

compare with master

unifiedsplit

@@ -20,6 +20,9 @@ module Docker.Client.Api (

20 , listImages

21 , buildImageFromDockerfile

22 , pullImage

23+ -- * Network

24+ , createNetwork

25+ , removeNetwork

23 -- * Other

26 -- * Other

24 , getDockerVersion

27 , getDockerVersion

25 ) where

28 ) where

@@ -207,3 +210,11 @@ buildImageFromDockerfile opts base = do

207pullImage :: forall m b . (MonadIO m, MonadMask m) => T.Text -> Tag -> Sink BS.ByteString m b -> DockerT m (Either DockerError b)

210pullImage :: forall m b . (MonadIO m, MonadMask m) => T.Text -> Tag -> Sink BS.ByteString m b -> DockerT m (Either DockerError b)

208pullImage name tag = requestHelper' POST (CreateImageEndpoint name tag Nothing)

211pullImage name tag = requestHelper' POST (CreateImageEndpoint name tag Nothing)

209

212

213+-- | Creates network

214+createNetwork :: forall m. (MonadIO m, MonadMask m) => CreateNetworkOpts -> DockerT m (Either DockerError NetworkID)

215+createNetwork opts = requestHelper POST (CreateNetworkEndpoint opts) >>= parseResponse

216+

217+-- | Removes a network

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

219+removeNetwork nid = requestUnit DELETE $ RemoveNetworkEndpoint nid

220+

src/Docker/Client/Http.hs+10

@@ -273,4 +273,14 @@ statusCodeToError (CreateImageEndpoint _ _ _) st =

273 Nothing

274 else

275 Just $ DockerInvalidStatusCode st

276+statusCodeToError (CreateNetworkEndpoint _) st =

277+ if st == status201 then

278+ Nothing

279+ else

280+ Just $ DockerInvalidStatusCode st

281+statusCodeToError (RemoveNetworkEndpoint _) st =

282+ if st == status204 then

283+ Nothing

284+ else

285+ Just $ DockerInvalidStatusCode st

276

286

src/Docker/Client/Internal.hs+4

@@ -75,6 +75,8 @@ getEndpoint v (CreateImageEndpoint name tag _) = encodeURLWithQuery [v, "images"

75 where query = [("fromImage", Just n), ("tag", Just t)]

76 n = encodeQ $ T.unpack name

77 t = encodeQ $ T.unpack tag

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

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

79getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

81getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

80getEndpointRequestBody VersionEndpoint = Nothing

82getEndpointRequestBody VersionEndpoint = Nothing

@@ -94,6 +96,8 @@ getEndpointRequestBody (InspectContainerEndpoint _) = Nothing

95getEndpointRequestBody (BuildImageEndpoint _ fp) = Just $ requestBodySourceChunked $ CB.sourceFile fp

97getEndpointRequestBody (BuildImageEndpoint _ fp) = Just $ requestBodySourceChunked $ CB.sourceFile fp

96getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing

98getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing

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

100+getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing

101

98getEndpointContentType :: Endpoint -> BSC.ByteString

102getEndpointContentType :: Endpoint -> BSC.ByteString

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

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

src/Docker/Client/Types.hs+57

@@ -11,6 +11,9 @@ module Docker.Client.Types (

11 , ImageID

12 , fromImageID

13 , toImageID

14+ , NetworkID

15+ , fromNetworkID

16+ , toNetworkID

14 , Timeout(..)

17 , Timeout(..)

15 , StatusCode(..)

18 , StatusCode(..)

16 , Signal(..)

19 , Signal(..)

@@ -43,6 +46,8 @@ module Docker.Client.Types (

43 , TailLogOpt(..)

46 , TailLogOpt(..)

44 , LogOpts(..)

47 , LogOpts(..)

45 , defaultLogOpts

48 , defaultLogOpts

49+ , CreateNetworkOpts(..)

50+ , defaultCreateNetworkOpts

46 , VolumePermission(..)

51 , VolumePermission(..)

47 , Bind(..)

52 , Bind(..)

48 , Volume(..)

53 , Volume(..)

@@ -129,6 +134,8 @@ data Endpoint =

129 | InspectContainerEndpoint ContainerID

134 | InspectContainerEndpoint ContainerID

130 | BuildImageEndpoint BuildOpts FilePath

135 | BuildImageEndpoint BuildOpts FilePath

131 | CreateImageEndpoint T.Text Tag (Maybe T.Text) -- ^ Either pull an image from docker hub or imports an image from a tarball (or URL)

136 | CreateImageEndpoint T.Text Tag (Maybe T.Text) -- ^ Either pull an image from docker hub or imports an image from a tarball (or URL)

137+ | CreateNetworkEndpoint CreateNetworkOpts

138+ | RemoveNetworkEndpoint NetworkID

132 deriving (Eq, Show)

139 deriving (Eq, Show)

133

140

134-- | We should newtype this

141-- | We should newtype this

@@ -811,6 +818,36 @@ defaultLogOpts = LogOpts { stdout = True

811 , tail = All

818 , tail = All

812 }

819 }

813

820

821+-- | Options for creating a network

822+data CreateNetworkOpts = CreateNetworkOpts

823+ { createNetworkName :: Text -- ^ The network's name

824+ , createNetworkCheckDuplicate :: Bool -- ^ Check for networks with duplicate names.

825+ , createNetworkDriver :: Text -- ^ Name of the network driver plugin to use.

826+ , createNetworkInternal :: Bool -- ^ Restrict external access to the network.

827+ , createNetworkEnableIPv6 :: Bool -- ^ Enable IPv6 on the network.

828+ } deriving (Eq, Show)

829+

830+-- | Sensible defalut for create network options

831+defaultCreateNetworkOpts :: Text -> CreateNetworkOpts

832+defaultCreateNetworkOpts name =

833+ CreateNetworkOpts

834+ { createNetworkName = name

835+ , createNetworkCheckDuplicate = False

836+ , createNetworkDriver = "bridge"

837+ , createNetworkInternal = True

838+ , createNetworkEnableIPv6 = False

839+ }

840+

841+instance ToJSON CreateNetworkOpts where

842+ toJSON opts =

843+ object

844+ [ "Name" .= createNetworkName opts

845+ , "CheckDuplicate" .= createNetworkCheckDuplicate opts

846+ , "Driver" .= createNetworkDriver opts

847+ , "Internal" .= createNetworkInternal opts

848+ , "EnableIPv6" .= createNetworkEnableIPv6 opts

849+ ]

850+

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

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

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

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

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

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

@@ -986,6 +1023,26 @@ instance ToJSON NetworkMode where

986 toJSON NetworkDisabled = JSON.String "none"

1023 toJSON NetworkDisabled = JSON.String "none"

987 toJSON (NetworkNamed n) = JSON.String n

1024 toJSON (NetworkNamed n) = JSON.String n

988

1025

1026+newtype NetworkID = NetworkID Text

1027+ deriving (Eq, Show)

1028+

1029+-- | Used for extracting the id of the container from the newtype

1030+fromNetworkID :: NetworkID -> Text

1031+fromNetworkID (NetworkID t) = t

1032+

1033+-- | Used for parsing a Text value into a NetworkID.

1034+toNetworkID :: Text -> Maybe NetworkID

1035+toNetworkID t = Just $ NetworkID t

1036+

1037+instance FromJSON NetworkID where

1038+ parseJSON (JSON.Object o) = do

1039+ nid <- o .: "Id"

1040+ return $ NetworkID nid

1041+ parseJSON _ = fail "NetworkID is not an object."

1042+

1043+instance ToJSON NetworkID where

1044+ toJSON (NetworkID nid) = object ["Id" .= nid]

1045+

989data PortType = TCP | UDP deriving (Eq, Generic, Read, Ord)

1046data PortType = TCP | UDP deriving (Eq, Generic, Read, Ord)

990

1047

991instance Show PortType where

1048instance Show PortType where

tests/tests.hs+10

@@ -114,6 +114,15 @@ testRunAndReadLogHelper networkingConfig =

114 isRightUnit (Right ()) = True

115 isRightUnit _ = False

116

117+testCreateRemoveNetwork :: IO ()

118+testCreateRemoveNetwork = do

119+ runDocker $ do

120+ createStatus <- createNetwork $ defaultCreateNetworkOpts "test-network"

121+ lift $ assertBool ("creating a network, unexpected status: " ++ show createStatus) $ isRight createStatus

122+ nid <- fromRight createStatus

123+ removeStatus <- removeNetwork nid

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

125+

117testLogDriverOptionsJson :: TestTree

126testLogDriverOptionsJson :: TestTree

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

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

119 where

128 where

@@ -217,6 +226,7 @@ integrationTests =

217 , testCase "Run a dummy container and read its log" testRunAndReadLog

226 , testCase "Run a dummy container and read its log" testRunAndReadLog

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

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

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

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

229+ , testCase "Create and remove a network" testCreateRemoveNetwork

220 ]

230 ]

221

231

222jsonTests :: TestTree

232jsonTests :: TestTree