60cc72f · docker-hs · git.iko.soy

git.iko.soy/docker-hs

on master help sign in

Implement network alias configuration via NetworkingConfig

60cc72fDaQuirm9 years ago

src/Docker/Client/Types.hs+34−3

compare with master

unifiedsplit

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

68 , UTSMode(..)

69 , HostConfig(..)

70 , defaultHostConfig

71+ , NetworkingConfig(..)

72+ , EndpointConfig(..)

71 , Ulimit(..)

73 , Ulimit(..)

72 , ContainerResources(..)

74 , ContainerResources(..)

73 , defaultContainerResources

75 , defaultContainerResources

@@ -611,20 +613,45 @@ instance FromJSON Image where

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

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

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

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

613

615

616+-- | Alias for Aliases.

617+type Alias = Text

618+

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

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

621+

622+instance ToJSON EndpointConfig where

623+ toJSON (EndpointConfig aliases) = JSON.object

624+ [ "Aliases" .= aliases

625+ ]

626+

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

628+newtype NetworkingConfig = NetworkingConfig

629+ { endpointsConfig :: HM.HashMap Text EndpointConfig

630+ } deriving (Eq, Show)

631+

632+instance ToJSON NetworkingConfig where

633+ toJSON (NetworkingConfig endpointsConfig) = JSON.object

634+ [ "EndpointsConfig" .= endpointsConfig

635+ ]

614

636

615-- | Options used for creating a Container.

637-- | Options used for creating a Container.

616data CreateOpts = CreateOpts {

638data CreateOpts = CreateOpts {

617 containerConfig :: ContainerConfig

639 containerConfig :: ContainerConfig

618 , hostConfig :: HostConfig

640 , hostConfig :: HostConfig

641+ , networkingConfig :: Maybe NetworkingConfig

619 } deriving (Eq, Show)

642 } deriving (Eq, Show)

620

643

621instance ToJSON CreateOpts where

644instance ToJSON CreateOpts where

622− toJSON (CreateOpts cc hc) = do

645+ toJSON (CreateOpts cc hc nc) = do

623 let ccJSON = toJSON cc

646 let ccJSON = toJSON cc

624 let hcJSON = toJSON hc

647 let hcJSON = toJSON hc

625 case ccJSON of

648 case ccJSON of

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

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

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

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

651+ let o2 = case nc of

652+ Nothing -> o1

653+ Just _ -> HM.insert "NetworkingConfig" (toJSON nc) o1

654+ JSON.Object o2

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

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

629

656

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

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

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

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

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

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

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

708defaultCreateOpts :: T.Text -> CreateOpts

735defaultCreateOpts :: T.Text -> CreateOpts

736+defaultCreateOpts imageName = CreateOpts

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

737+ { containerConfig = defaultContainerConfig imageName

738+ , hostConfig = defaultHostConfig

739+ , networkingConfig = Nothing

740+ }

710

741

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

742-- | 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 _.

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

tests/tests.hs+17−1

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

14import Control.Monad.IO.Class

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

16import qualified Data.Aeson as JSON

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

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

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

18 _String, _Value)

19 _String, _Value)

19import qualified Data.ByteString as B

20import qualified Data.ByteString as B

@@ -92,7 +93,7 @@ testRunAndReadLog :: IO ()

92testRunAndReadLog =

93testRunAndReadLog =

93 runDocker $

94 runDocker $

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

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

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

96+ containerId <- createContainer (CreateOpts containerConfig defaultHostConfig Nothing) Nothing

96 c <- fromRight containerId

97 c <- fromRight containerId

97 status1 <- startContainer defaultStartOpts c

98 status1 <- startContainer defaultStartOpts c

98 _ <- inspectContainer c >>= fromRight

99 _ <- inspectContainer c >>= fromRight

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

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

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

185 Just (EnvVar "cellar" "door")

186 Just (EnvVar "cellar" "door")

186

187

188+testNetworkingConfigJson :: TestTree

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

190+ where

191+ testSampleEncode =

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

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

194+ JSON.object

195+ [ "EndpointsConfig" .= JSON.object

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

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

198+ ]

199+ ]

200+ ]

201+

187integrationTests :: TestTree

202integrationTests :: TestTree

188integrationTests =

203integrationTests =

189 testGroup

204 testGroup

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

206 , testLogDriverOptionsJson

221 , testLogDriverOptionsJson

207 , testEntrypointJson

222 , testEntrypointJson

208 , testEnvVarJson

223 , testEnvVarJson

224+ , testNetworkingConfigJson

209 ]

225 ]

210

226

211setup :: IO ()

227setup :: IO ()