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

git.iko.soy/docker-hs

Implement create and remove network API

Options for creating a network are not complete and intended for extension in the future.

commit84732d3ed5ccf03457d16308ece104db6bb2e700 authorAlex K <flskif@gmail.com> dateMon 18 Jun 2018, 16:52 (8 years ago) parent60babd4

5 files changed+92

compare with master

unifiedsplit

src/Docker/Client/Api.hs+11 src/Docker/Client/Http.hs+10 src/Docker/Client/Internal.hs+4 src/Docker/Client/Types.hs+57 tests/tests.hs+10

src/Docker/Client/Api.hs+11

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

2020 , listImages

2121 , buildImageFromDockerfile

2222 , pullImage

23+ -- * Network

24+ , createNetwork

25+ , removeNetwork

2326 -- * Other

2427 , getDockerVersion

2528 ) where

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

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

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

209212

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 =

273273 Nothing

274274 else

275275 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

276286

src/Docker/Client/Internal.hs+4

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

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

7676 n = encodeQ $ T.unpack name

7777 t = encodeQ $ T.unpack tag

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

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

7880

7981getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

8082getEndpointRequestBody VersionEndpoint = Nothing

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

9496

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

9698getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing

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

100+getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing

97101

98102getEndpointContentType :: Endpoint -> BSC.ByteString

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

src/Docker/Client/Types.hs+57

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

1111 , ImageID

1212 , fromImageID

1313 , toImageID

14+ , NetworkID

15+ , fromNetworkID

16+ , toNetworkID

1417 , Timeout(..)

1518 , StatusCode(..)

1619 , Signal(..)

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

4346 , TailLogOpt(..)

4447 , LogOpts(..)

4548 , defaultLogOpts

49+ , CreateNetworkOpts(..)

50+ , defaultCreateNetworkOpts

4651 , VolumePermission(..)

4752 , Bind(..)

4853 , Volume(..)

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

129134 | InspectContainerEndpoint ContainerID

130135 | BuildImageEndpoint BuildOpts FilePath

131136 | 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

132139 deriving (Eq, Show)

133140

134141-- | We should newtype this

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

811818 , tail = All

812819 }

813820

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+

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

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

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

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

9861023 toJSON NetworkDisabled = JSON.String "none"

9871024 toJSON (NetworkNamed n) = JSON.String n

9881025

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+

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

9901047

9911048instance Show PortType where

tests/tests.hs+10

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

114114 isRightUnit (Right ()) = True

115115 isRightUnit _ = False

116116

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+

117126testLogDriverOptionsJson :: TestTree

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

119128 where

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

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

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

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

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

220230 ]

221231

222232jsonTests :: TestTree