mirror of
https://github.com/ilyakooo0/docker-hs.git
synced 2024-09-11 10:35:29 +03:00
Implement create and remove network API
Options for creating a network are not complete and intended for extension in the future.
This commit is contained in:
parent
60babd47df
commit
84732d3ed5
@ -20,6 +20,9 @@ module Docker.Client.Api (
|
||||
, listImages
|
||||
, buildImageFromDockerfile
|
||||
, pullImage
|
||||
-- * Network
|
||||
, createNetwork
|
||||
, removeNetwork
|
||||
-- * Other
|
||||
, getDockerVersion
|
||||
) where
|
||||
@ -207,3 +210,11 @@ buildImageFromDockerfile opts base = do
|
||||
pullImage :: forall m b . (MonadIO m, MonadMask m) => T.Text -> Tag -> Sink BS.ByteString m b -> DockerT m (Either DockerError b)
|
||||
pullImage name tag = requestHelper' POST (CreateImageEndpoint name tag Nothing)
|
||||
|
||||
-- | Creates network
|
||||
createNetwork :: forall m. (MonadIO m, MonadMask m) => CreateNetworkOpts -> DockerT m (Either DockerError NetworkID)
|
||||
createNetwork opts = requestHelper POST (CreateNetworkEndpoint opts) >>= parseResponse
|
||||
|
||||
-- | Removes a network
|
||||
removeNetwork :: forall m. (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError ())
|
||||
removeNetwork nid = requestUnit DELETE $ RemoveNetworkEndpoint nid
|
||||
|
||||
|
@ -273,4 +273,14 @@ statusCodeToError (CreateImageEndpoint _ _ _) st =
|
||||
Nothing
|
||||
else
|
||||
Just $ DockerInvalidStatusCode st
|
||||
statusCodeToError (CreateNetworkEndpoint _) st =
|
||||
if st == status201 then
|
||||
Nothing
|
||||
else
|
||||
Just $ DockerInvalidStatusCode st
|
||||
statusCodeToError (RemoveNetworkEndpoint _) st =
|
||||
if st == status204 then
|
||||
Nothing
|
||||
else
|
||||
Just $ DockerInvalidStatusCode st
|
||||
|
||||
|
@ -75,6 +75,8 @@ getEndpoint v (CreateImageEndpoint name tag _) = encodeURLWithQuery [v, "images"
|
||||
where query = [("fromImage", Just n), ("tag", Just t)]
|
||||
n = encodeQ $ T.unpack name
|
||||
t = encodeQ $ T.unpack tag
|
||||
getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"]
|
||||
getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid]
|
||||
|
||||
getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody
|
||||
getEndpointRequestBody VersionEndpoint = Nothing
|
||||
@ -94,6 +96,8 @@ getEndpointRequestBody (InspectContainerEndpoint _) = Nothing
|
||||
|
||||
getEndpointRequestBody (BuildImageEndpoint _ fp) = Just $ requestBodySourceChunked $ CB.sourceFile fp
|
||||
getEndpointRequestBody (CreateImageEndpoint _ _ _) = Nothing
|
||||
getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)
|
||||
getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing
|
||||
|
||||
getEndpointContentType :: Endpoint -> BSC.ByteString
|
||||
getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar"
|
||||
|
@ -11,6 +11,9 @@ module Docker.Client.Types (
|
||||
, ImageID
|
||||
, fromImageID
|
||||
, toImageID
|
||||
, NetworkID
|
||||
, fromNetworkID
|
||||
, toNetworkID
|
||||
, Timeout(..)
|
||||
, StatusCode(..)
|
||||
, Signal(..)
|
||||
@ -43,6 +46,8 @@ module Docker.Client.Types (
|
||||
, TailLogOpt(..)
|
||||
, LogOpts(..)
|
||||
, defaultLogOpts
|
||||
, CreateNetworkOpts(..)
|
||||
, defaultCreateNetworkOpts
|
||||
, VolumePermission(..)
|
||||
, Bind(..)
|
||||
, Volume(..)
|
||||
@ -129,6 +134,8 @@ data Endpoint =
|
||||
| InspectContainerEndpoint ContainerID
|
||||
| BuildImageEndpoint BuildOpts FilePath
|
||||
| CreateImageEndpoint T.Text Tag (Maybe T.Text) -- ^ Either pull an image from docker hub or imports an image from a tarball (or URL)
|
||||
| CreateNetworkEndpoint CreateNetworkOpts
|
||||
| RemoveNetworkEndpoint NetworkID
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | We should newtype this
|
||||
@ -811,6 +818,36 @@ defaultLogOpts = LogOpts { stdout = True
|
||||
, tail = All
|
||||
}
|
||||
|
||||
-- | Options for creating a network
|
||||
data CreateNetworkOpts = CreateNetworkOpts
|
||||
{ createNetworkName :: Text -- ^ The network's name
|
||||
, createNetworkCheckDuplicate :: Bool -- ^ Check for networks with duplicate names.
|
||||
, createNetworkDriver :: Text -- ^ Name of the network driver plugin to use.
|
||||
, createNetworkInternal :: Bool -- ^ Restrict external access to the network.
|
||||
, createNetworkEnableIPv6 :: Bool -- ^ Enable IPv6 on the network.
|
||||
} deriving (Eq, Show)
|
||||
|
||||
-- | Sensible defalut for create network options
|
||||
defaultCreateNetworkOpts :: Text -> CreateNetworkOpts
|
||||
defaultCreateNetworkOpts name =
|
||||
CreateNetworkOpts
|
||||
{ createNetworkName = name
|
||||
, createNetworkCheckDuplicate = False
|
||||
, createNetworkDriver = "bridge"
|
||||
, createNetworkInternal = True
|
||||
, createNetworkEnableIPv6 = False
|
||||
}
|
||||
|
||||
instance ToJSON CreateNetworkOpts where
|
||||
toJSON opts =
|
||||
object
|
||||
[ "Name" .= createNetworkName opts
|
||||
, "CheckDuplicate" .= createNetworkCheckDuplicate opts
|
||||
, "Driver" .= createNetworkDriver opts
|
||||
, "Internal" .= createNetworkInternal opts
|
||||
, "EnableIPv6" .= createNetworkEnableIPv6 opts
|
||||
]
|
||||
|
||||
-- TOOD: Add support for SELinux Volume labels (eg. "ro,z" or "ro/Z")
|
||||
-- | Set permissions on volumes that you mount in the container.
|
||||
data VolumePermission = ReadWrite | ReadOnly deriving (Eq, Show, Generic)
|
||||
@ -986,6 +1023,26 @@ instance ToJSON NetworkMode where
|
||||
toJSON NetworkDisabled = JSON.String "none"
|
||||
toJSON (NetworkNamed n) = JSON.String n
|
||||
|
||||
newtype NetworkID = NetworkID Text
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Used for extracting the id of the container from the newtype
|
||||
fromNetworkID :: NetworkID -> Text
|
||||
fromNetworkID (NetworkID t) = t
|
||||
|
||||
-- | Used for parsing a Text value into a NetworkID.
|
||||
toNetworkID :: Text -> Maybe NetworkID
|
||||
toNetworkID t = Just $ NetworkID t
|
||||
|
||||
instance FromJSON NetworkID where
|
||||
parseJSON (JSON.Object o) = do
|
||||
nid <- o .: "Id"
|
||||
return $ NetworkID nid
|
||||
parseJSON _ = fail "NetworkID is not an object."
|
||||
|
||||
instance ToJSON NetworkID where
|
||||
toJSON (NetworkID nid) = object ["Id" .= nid]
|
||||
|
||||
data PortType = TCP | UDP deriving (Eq, Generic, Read, Ord)
|
||||
|
||||
instance Show PortType where
|
||||
|
@ -114,6 +114,15 @@ testRunAndReadLogHelper networkingConfig =
|
||||
isRightUnit (Right ()) = True
|
||||
isRightUnit _ = False
|
||||
|
||||
testCreateRemoveNetwork :: IO ()
|
||||
testCreateRemoveNetwork = do
|
||||
runDocker $ do
|
||||
createStatus <- createNetwork $ defaultCreateNetworkOpts "test-network"
|
||||
lift $ assertBool ("creating a network, unexpected status: " ++ show createStatus) $ isRight createStatus
|
||||
nid <- fromRight createStatus
|
||||
removeStatus <- removeNetwork nid
|
||||
lift $ assertBool ("removing a network, unexpected status: " ++ show removeStatus) $ isRight removeStatus
|
||||
|
||||
testLogDriverOptionsJson :: TestTree
|
||||
testLogDriverOptionsJson = testGroup "Testing LogDriverOptions JSON" [test1, test2, test3]
|
||||
where
|
||||
@ -217,6 +226,7 @@ integrationTests =
|
||||
, testCase "Run a dummy container and read its log" testRunAndReadLog
|
||||
, testCase "Run a dummy container with networking and read its log" testRunAndReadLogWithNetworking
|
||||
, testCase "Try to stop a container that doesn't exist" testStopNonexisting
|
||||
, testCase "Create and remove a network" testCreateRemoveNetwork
|
||||
]
|
||||
|
||||
jsonTests :: TestTree
|
||||
|
Loading…
Reference in New Issue
Block a user