mirror of
https://github.com/ilyakooo0/docker-hs.git
synced 2024-09-11 10:35:29 +03:00
Implement network alias configuration via NetworkingConfig
This commit is contained in:
parent
53a0a4474a
commit
60cc72f325
@ -68,6 +68,8 @@ module Docker.Client.Types (
|
||||
, UTSMode(..)
|
||||
, HostConfig(..)
|
||||
, defaultHostConfig
|
||||
, NetworkingConfig(..)
|
||||
, EndpointConfig(..)
|
||||
, Ulimit(..)
|
||||
, ContainerResources(..)
|
||||
, defaultContainerResources
|
||||
@ -611,20 +613,45 @@ instance FromJSON Image where
|
||||
return $ DockerImage imageId imageCreated imageParentId imageRepoTags imageRepoDigests imageSize imageVirtualSize imageLabels
|
||||
parseJSON _ = fail "Failed to parse DockerImage."
|
||||
|
||||
-- | Alias for Aliases.
|
||||
type Alias = Text
|
||||
|
||||
-- | EndpointsConfig is container configuration for a specific network
|
||||
newtype EndpointConfig = EndpointConfig [Alias] deriving (Eq, Show)
|
||||
|
||||
instance ToJSON EndpointConfig where
|
||||
toJSON (EndpointConfig aliases) = JSON.object
|
||||
[ "Aliases" .= aliases
|
||||
]
|
||||
|
||||
-- | Data type for the NetworkingConfig section of the container settings
|
||||
newtype NetworkingConfig = NetworkingConfig
|
||||
{ endpointsConfig :: HM.HashMap Text EndpointConfig
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance ToJSON NetworkingConfig where
|
||||
toJSON (NetworkingConfig endpointsConfig) = JSON.object
|
||||
[ "EndpointsConfig" .= endpointsConfig
|
||||
]
|
||||
|
||||
-- | Options used for creating a Container.
|
||||
data CreateOpts = CreateOpts {
|
||||
containerConfig :: ContainerConfig
|
||||
, hostConfig :: HostConfig
|
||||
, networkingConfig :: Maybe NetworkingConfig
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance ToJSON CreateOpts where
|
||||
toJSON (CreateOpts cc hc) = do
|
||||
toJSON (CreateOpts cc hc nc) = do
|
||||
let ccJSON = toJSON cc
|
||||
let hcJSON = toJSON hc
|
||||
case ccJSON of
|
||||
JSON.Object (o :: HM.HashMap T.Text JSON.Value) -> do
|
||||
JSON.Object $ HM.insert "HostConfig" hcJSON o
|
||||
let o1 = HM.insert "HostConfig" hcJSON o
|
||||
let o2 = case nc of
|
||||
Nothing -> o1
|
||||
Just _ -> HM.insert "NetworkingConfig" (toJSON nc) o1
|
||||
JSON.Object o2
|
||||
_ -> error "ContainerConfig is not an object." -- This should never happen.
|
||||
|
||||
-- | Container configuration used for creating a container with sensible
|
||||
@ -706,7 +733,11 @@ defaultContainerResources = ContainerResources {
|
||||
-- | Default create options when creating a container. You only need to
|
||||
-- specify an image name and the rest is all sensible defaults.
|
||||
defaultCreateOpts :: T.Text -> CreateOpts
|
||||
defaultCreateOpts imageName = CreateOpts { containerConfig = defaultContainerConfig imageName, hostConfig = defaultHostConfig }
|
||||
defaultCreateOpts imageName = CreateOpts
|
||||
{ containerConfig = defaultContainerConfig imageName
|
||||
, hostConfig = defaultHostConfig
|
||||
, networkingConfig = Nothing
|
||||
}
|
||||
|
||||
-- | Override the key sequence for detaching a container.
|
||||
-- Format is a single character [a-Z] or ctrl-<value> where <value> is one of: a-z, @, ^, [, , or _.
|
||||
|
@ -14,6 +14,7 @@ import Control.Monad (forM_)
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import qualified Data.Aeson as JSON
|
||||
import Data.Aeson ((.=))
|
||||
import Data.Aeson.Lens (key, _Array, _Null, _Object,
|
||||
_String, _Value)
|
||||
import qualified Data.ByteString as B
|
||||
@ -92,7 +93,7 @@ testRunAndReadLog :: IO ()
|
||||
testRunAndReadLog =
|
||||
runDocker $
|
||||
do let containerConfig = (defaultContainerConfig (testImageName <> ":latest")) {env = [EnvVar "TEST" "123"]}
|
||||
containerId <- createContainer (CreateOpts containerConfig defaultHostConfig) Nothing
|
||||
containerId <- createContainer (CreateOpts containerConfig defaultHostConfig Nothing) Nothing
|
||||
c <- fromRight containerId
|
||||
status1 <- startContainer defaultStartOpts c
|
||||
_ <- inspectContainer c >>= fromRight
|
||||
@ -184,6 +185,20 @@ testEnvVarJson = testGroup "Testing EnvVar JSON" [testSampleEncode, testSampleDe
|
||||
testCase "Test fromJSON" $ assert $ (JSON.decode "\"cellar=door\"" :: Maybe EnvVar) ==
|
||||
Just (EnvVar "cellar" "door")
|
||||
|
||||
testNetworkingConfigJson :: TestTree
|
||||
testNetworkingConfigJson = testGroup "Testing NetworkingConfig JSON" [testSampleEncode]
|
||||
where
|
||||
testSampleEncode =
|
||||
let networkingConfig = NetworkingConfig $ HM.fromList [("custom-network", EndpointConfig ["cellar", "door"])]
|
||||
in testCase "Test toJSON" $ assert $ JSON.toJSON networkingConfig ==
|
||||
JSON.object
|
||||
[ "EndpointsConfig" .= JSON.object
|
||||
[ "custom-network" .= JSON.object
|
||||
[ "Aliases" .= (["cellar", "door"] :: [Text])
|
||||
]
|
||||
]
|
||||
]
|
||||
|
||||
integrationTests :: TestTree
|
||||
integrationTests =
|
||||
testGroup
|
||||
@ -206,6 +221,7 @@ jsonTests =
|
||||
, testLogDriverOptionsJson
|
||||
, testEntrypointJson
|
||||
, testEnvVarJson
|
||||
, testNetworkingConfigJson
|
||||
]
|
||||
|
||||
setup :: IO ()
|
||||
|
Loading…
Reference in New Issue
Block a user