Implement create and remove network API

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

src/Docker/Client/Api.hs

@@ -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
+

src/Docker/Client/Http.hs

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

src/Docker/Client/Internal.hs

@@ -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"

src/Docker/Client/Types.hs

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

tests/tests.hs

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