940eb34 · docker-hs · git.iko.soy

git.iko.soy/docker-hs

on master help sign in

Merge pull request #62 from flskif/create-network

940eb34JP8 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+94−5

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

@@ -68,6 +73,8 @@ module Docker.Client.Types (

68 , UTSMode(..)

73 , UTSMode(..)

69 , HostConfig(..)

74 , HostConfig(..)

70 , defaultHostConfig

75 , defaultHostConfig

76+ , NetworkingConfig(..)

77+ , EndpointConfig(..)

71 , Ulimit(..)

78 , Ulimit(..)

72 , ContainerResources(..)

79 , ContainerResources(..)

73 , defaultContainerResources

80 , defaultContainerResources

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

127 | InspectContainerEndpoint ContainerID

134 | InspectContainerEndpoint ContainerID

128 | BuildImageEndpoint BuildOpts FilePath

135 | BuildImageEndpoint BuildOpts FilePath

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

130 deriving (Eq, Show)

139 deriving (Eq, Show)

131

140

132-- | We should newtype this

141-- | We should newtype this

@@ -611,20 +620,46 @@ instance FromJSON Image where

611 return $ DockerImage imageId imageCreated imageParentId imageRepoTags imageRepoDigests imageSize imageVirtualSize imageLabels

620 return $ DockerImage imageId imageCreated imageParentId imageRepoTags imageRepoDigests imageSize imageVirtualSize imageLabels

612 parseJSON _ = fail "Failed to parse DockerImage."

621 parseJSON _ = fail "Failed to parse DockerImage."

613

622

623+-- | Alias for Aliases.

624+type Alias = Text

625+

626+-- | EndpointsConfig is container configuration for a specific network

627+newtype EndpointConfig = EndpointConfig [Alias] deriving (Eq, Show)

628+

629+instance ToJSON EndpointConfig where

630+ toJSON (EndpointConfig aliases) = JSON.object

631+ [ "Aliases" .= aliases

632+ ]

633+

634+-- | Alias for endpoint name

635+type EndpointName = Text

636+

637+-- | Data type for the NetworkingConfig section of the container settings

638+newtype NetworkingConfig = NetworkingConfig

639+ { endpointsConfig :: HM.HashMap EndpointName EndpointConfig

640+ } deriving (Eq, Show)

641+

642+instance ToJSON NetworkingConfig where

643+ toJSON (NetworkingConfig endpointsConfig) = JSON.object

644+ [ "EndpointsConfig" .= endpointsConfig

645+ ]

614

646

615-- | Options used for creating a Container.

647-- | Options used for creating a Container.

616data CreateOpts = CreateOpts {

648data CreateOpts = CreateOpts {

617− containerConfig :: ContainerConfig

649+ containerConfig :: ContainerConfig

618− , hostConfig :: HostConfig

650+ , hostConfig :: HostConfig

651+ , networkingConfig :: NetworkingConfig

619 } deriving (Eq, Show)

652 } deriving (Eq, Show)

620

653

621instance ToJSON CreateOpts where

654instance ToJSON CreateOpts where

622− toJSON (CreateOpts cc hc) = do

655+ toJSON (CreateOpts cc hc nc) = do

623 let ccJSON = toJSON cc

656 let ccJSON = toJSON cc

624 let hcJSON = toJSON hc

657 let hcJSON = toJSON hc

625 case ccJSON of

658 case ccJSON of

626 JSON.Object (o :: HM.HashMap T.Text JSON.Value) -> do

659 JSON.Object (o :: HM.HashMap T.Text JSON.Value) -> do

627− JSON.Object $ HM.insert "HostConfig" hcJSON o

660+ let o1 = HM.insert "HostConfig" hcJSON o

661+ let o2 = HM.insert "NetworkingConfig" (toJSON nc) o1

662+ JSON.Object o2

628 _ -> error "ContainerConfig is not an object." -- This should never happen.

663 _ -> error "ContainerConfig is not an object." -- This should never happen.

629

664

630-- | Container configuration used for creating a container with sensible

665-- | Container configuration used for creating a container with sensible

@@ -706,7 +741,11 @@ defaultContainerResources = ContainerResources {

706-- | Default create options when creating a container. You only need to

741-- | Default create options when creating a container. You only need to

707-- specify an image name and the rest is all sensible defaults.

742-- specify an image name and the rest is all sensible defaults.

708defaultCreateOpts :: T.Text -> CreateOpts

743defaultCreateOpts :: T.Text -> CreateOpts

744+defaultCreateOpts imageName = CreateOpts

709−defaultCreateOpts imageName = CreateOpts { containerConfig = defaultContainerConfig imageName, hostConfig = defaultHostConfig }

745+ { containerConfig = defaultContainerConfig imageName

746+ , hostConfig = defaultHostConfig

747+ , networkingConfig = NetworkingConfig HM.empty

748+ }

710

749

711-- | Override the key sequence for detaching a container.

750-- | Override the key sequence for detaching a container.

712-- Format is a single character [a-Z] or ctrl-<value> where <value> is one of: a-z, @, ^, [, , or _.

751-- Format is a single character [a-Z] or ctrl-<value> where <value> is one of: a-z, @, ^, [, , or _.

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

779 , tail = All

818 , tail = All

780 }

819 }

781

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+

782-- 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")

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

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

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

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

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

954 toJSON NetworkDisabled = JSON.String "none"

1023 toJSON NetworkDisabled = JSON.String "none"

955 toJSON (NetworkNamed n) = JSON.String n

1024 toJSON (NetworkNamed n) = JSON.String n

956

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+

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

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

958

1047

959instance Show PortType where

1048instance Show PortType where

tests/tests.hs+42−2

@@ -2,6 +2,7 @@

3module Main where

5+import Data.Either (rights)

5import Prelude hiding (all)

6import Prelude hiding (all)

6import qualified Test.QuickCheck.Monadic as QCM

7import qualified Test.QuickCheck.Monadic as QCM

7import Test.Tasty

8import Test.Tasty

@@ -14,6 +15,7 @@ import Control.Monad (forM_)

14import Control.Monad.IO.Class

15import Control.Monad.IO.Class

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

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

16import qualified Data.Aeson as JSON

17import qualified Data.Aeson as JSON

18+import Data.Aeson ((.=))

17import Data.Aeson.Lens (key, _Array, _Null, _Object,

19import Data.Aeson.Lens (key, _Array, _Null, _Object,

18 _String, _Value)

20 _String, _Value)

19import qualified Data.ByteString as B

21import qualified Data.ByteString as B

@@ -88,11 +90,19 @@ testBuildFromDockerfile = do

88 r <- buildImageFromDockerfile (defaultBuildOpts "docker-hs/dockerfile-test") ctxDir

90 r <- buildImageFromDockerfile (defaultBuildOpts "docker-hs/dockerfile-test") ctxDir

89 lift $ assert $ isRight r

91 lift $ assert $ isRight r

93+

91testRunAndReadLog :: IO ()

94testRunAndReadLog :: IO ()

92−testRunAndReadLog =

95+testRunAndReadLog = testRunAndReadLogHelper $ NetworkingConfig HM.empty

96+

97+testRunAndReadLogWithNetworking :: IO ()

98+testRunAndReadLogWithNetworking = testRunAndReadLogHelper $ NetworkingConfig $ HM.fromList [("test-network", EndpointConfig ["cellar-door"])]

99+

100+testRunAndReadLogHelper :: NetworkingConfig -> IO ()

101+testRunAndReadLogHelper networkingConfig =

93 runDocker $

102 runDocker $

94 do let containerConfig = (defaultContainerConfig (testImageName <> ":latest")) {env = [EnvVar "TEST" "123"]}

103 do let containerConfig = (defaultContainerConfig (testImageName <> ":latest")) {env = [EnvVar "TEST" "123"]}

104+ createdNetworks <- rights <$> mapM createNetworkWithName networkNames

95− containerId <- createContainer (CreateOpts containerConfig defaultHostConfig) Nothing

105+ containerId <- createContainer (CreateOpts containerConfig defaultHostConfig networkingConfig) Nothing

96 c <- fromRight containerId

106 c <- fromRight containerId

97 status1 <- startContainer defaultStartOpts c

107 status1 <- startContainer defaultStartOpts c

98 _ <- inspectContainer c >>= fromRight

108 _ <- inspectContainer c >>= fromRight

@@ -102,9 +112,22 @@ testRunAndReadLog =

102 lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)

112 lift $ assert $ (C.pack "123") `C.isInfixOf` (toStrict1 logs)

103 status3 <- deleteContainer (DeleteOpts True True) c

113 status3 <- deleteContainer (DeleteOpts True True) c

104 lift $ assertBool ("deleting container, unexpected status: " ++ show status3) $ isRightUnit status3

114 lift $ assertBool ("deleting container, unexpected status: " ++ show status3) $ isRightUnit status3

115+ mapM_ removeNetwork createdNetworks

105 where

116 where

106 isRightUnit (Right ()) = True

117 isRightUnit (Right ()) = True

107 isRightUnit _ = False

118 isRightUnit _ = False

119+ networkNames = HM.keys $ endpointsConfig networkingConfig

120+ createNetworkWithName name = createNetwork $

121+ (defaultCreateNetworkOpts name) { createNetworkCheckDuplicate = True }

122+

123+testCreateRemoveNetwork :: IO ()

124+testCreateRemoveNetwork = do

125+ runDocker $ do

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

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

128+ nid <- fromRight createStatus

129+ removeStatus <- removeNetwork nid

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

108

131

109testLogDriverOptionsJson :: TestTree

132testLogDriverOptionsJson :: TestTree

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

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

@@ -184,6 +207,20 @@ testEnvVarJson = testGroup "Testing EnvVar JSON" [testSampleEncode, testSampleDe

184 testCase "Test fromJSON" $ assert $ (JSON.decode "\"cellar=door\"" :: Maybe EnvVar) ==

207 testCase "Test fromJSON" $ assert $ (JSON.decode "\"cellar=door\"" :: Maybe EnvVar) ==

185 Just (EnvVar "cellar" "door")

208 Just (EnvVar "cellar" "door")

186

209

210+testNetworkingConfigJson :: TestTree

211+testNetworkingConfigJson = testGroup "Testing NetworkingConfig JSON" [testSampleEncode]

212+ where

213+ testSampleEncode =

214+ let networkingConfig = NetworkingConfig $ HM.fromList [("custom-network", EndpointConfig ["cellar", "door"])]

215+ in testCase "Test toJSON" $ assert $ JSON.toJSON networkingConfig ==

216+ JSON.object

217+ [ "EndpointsConfig" .= JSON.object

218+ [ "custom-network" .= JSON.object

219+ [ "Aliases" .= (["cellar", "door"] :: [Text])

220+ ]

221+ ]

222+ ]

223+

187integrationTests :: TestTree

224integrationTests :: TestTree

188integrationTests =

225integrationTests =

189 testGroup

226 testGroup

@@ -193,7 +230,9 @@ integrationTests =

193 , testCase "Find image by name" testFindImage

230 , testCase "Find image by name" testFindImage

194 , testCase "List containers" testListContainers

231 , testCase "List containers" testListContainers

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

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

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

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

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

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

197 ]

236 ]

198

237

199jsonTests :: TestTree

238jsonTests :: TestTree

@@ -206,6 +245,7 @@ jsonTests =

206 , testLogDriverOptionsJson

245 , testLogDriverOptionsJson

207 , testEntrypointJson

246 , testEntrypointJson

208 , testEnvVarJson

247 , testEnvVarJson

248+ , testNetworkingConfigJson

209 ]

249 ]

210

250

211setup :: IO ()

251setup :: IO ()