master...78e5ae2 · docker-hs

git.iko.soy/docker-hs

on 78e5ae2 help sign in

src/Docker/Client/Api.hs+9

since splitsnapshots

unifiedsplit

@@ -24,6 +24,8 @@ module Docker.Client.Api (

24 -- * Network

25 , createNetwork

26 , removeNetwork

27+ , listNetworks

28+ , inspectNetwork

27 -- * Other

29 -- * Other

28 , getDockerVersion

30 , getDockerVersion

29 ) where

31 ) where

@@ -225,3 +227,10 @@ createNetwork opts = requestHelper POST (CreateNetworkEndpoint opts) >>= parseR

225removeNetwork :: forall m. (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError ())

227removeNetwork :: forall m. (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError ())

226removeNetwork nid = requestUnit DELETE $ RemoveNetworkEndpoint nid

228removeNetwork nid = requestUnit DELETE $ RemoveNetworkEndpoint nid

227

229

230+-- | Lists networks optionally matching a list of 'NetworkFilter's.

231+listNetworks :: forall m . (MonadIO m, MonadMask m) => [NetworkFilter] -> DockerT m (Either DockerError [NetworkDetails])

232+listNetworks nfs = requestHelper GET (ListNetworksEndpoint nfs) >>= parseResponse

233+

234+-- | Gets 'NetworkDetails' for a network, given its name or id.

235+inspectNetwork :: forall m . (MonadIO m, MonadMask m) => NetworkID -> DockerT m (Either DockerError NetworkDetails)

236+inspectNetwork nid = requestHelper GET (InspectNetworkEndpoint nid) >>= parseResponse

src/Docker/Client/Http.hs+10

@@ -288,3 +288,13 @@ statusCodeToError (RemoveNetworkEndpoint _) st =

288 Nothing

289 else

290 Just $ DockerInvalidStatusCode st

291+statusCodeToError (ListNetworksEndpoint _) st =

292+ if st == status200 then

293+ Nothing

294+ else

295+ Just $ DockerInvalidStatusCode st

296+statusCodeToError (InspectNetworkEndpoint _) st =

297+ if st == status200 then

298+ Nothing

299+ else

300+ Just $ DockerInvalidStatusCode st

src/Docker/Client/Internal.hs+17−12

@@ -1,17 +1,18 @@

1module Docker.Client.Internal where

3−import Blaze.ByteString.Builder (toByteString)

3+import Blaze.ByteString.Builder (toByteString)

4−import qualified Data.Aeson as JSON

4+import qualified Data.Aeson as JSON

5−import Data.ByteString (ByteString)

5+import Data.ByteString (ByteString)

6−import qualified Data.ByteString.Char8 as BSC

6+import qualified Data.ByteString.Char8 as BSC

7−import qualified Data.Conduit.Binary as CB

7+import qualified Data.ByteString.Lazy.Char8 as BSLC

8+import qualified Data.Conduit.Binary as CB

8−import qualified Data.Text as T

9+import qualified Data.Text as T

9−import Data.Text.Encoding (decodeUtf8, encodeUtf8)

10+import Data.Text.Encoding (decodeUtf8, encodeUtf8)

10−import qualified Network.HTTP.Client as HTTP

11+import qualified Network.HTTP.Client as HTTP

11−import Network.HTTP.Conduit (requestBodySourceChunked)

12+import Network.HTTP.Conduit (requestBodySourceChunked)

12−import Network.HTTP.Types (Query, encodePath,

13+import Network.HTTP.Types (Query, encodePath,

13− encodePathSegments)

14+ encodePathSegments)

14−import Prelude hiding (all)

15+import Prelude hiding (all)

16import Docker.Client.Types

17import Docker.Client.Types

@@ -78,6 +79,8 @@ getEndpoint v (CreateImageEndpoint name tag _) = encodeURLWithQuery [v, "images"

78getEndpoint v (DeleteImageEndpoint _ cid) = encodeURL [v, "images", fromImageID cid]

79getEndpoint v (DeleteImageEndpoint _ cid) = encodeURL [v, "images", fromImageID cid]

79getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"]

80getEndpoint v (CreateNetworkEndpoint _) = encodeURL [v, "networks", "create"]

80getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid]

81getEndpoint v (RemoveNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid]

82+getEndpoint v (ListNetworksEndpoint nfs) = encodeURLWithQuery [v, "networks"] [("filters", Just . BSLC.toStrict $ JSON.encode nfs)]

83+getEndpoint v (InspectNetworkEndpoint nid) = encodeURL [v, "networks", fromNetworkID nid]

82getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

85getEndpointRequestBody :: Endpoint -> Maybe HTTP.RequestBody

83getEndpointRequestBody VersionEndpoint = Nothing

86getEndpointRequestBody VersionEndpoint = Nothing

@@ -101,6 +104,8 @@ getEndpointRequestBody (DeleteImageEndpoint _ _) = Nothing

101

104

102getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)

105getEndpointRequestBody (CreateNetworkEndpoint opts) = Just $ HTTP.RequestBodyLBS (JSON.encode opts)

103getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing

106getEndpointRequestBody (RemoveNetworkEndpoint _) = Nothing

107+getEndpointRequestBody (ListNetworksEndpoint _) = Nothing

108+getEndpointRequestBody (InspectNetworkEndpoint _) = Nothing

104

109

105getEndpointContentType :: Endpoint -> BSC.ByteString

110getEndpointContentType :: Endpoint -> BSC.ByteString

106getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar"

111getEndpointContentType (BuildImageEndpoint _ _) = BSC.pack "application/tar"

src/Docker/Client/Types.hs+168−4

@@ -76,6 +76,16 @@ module Docker.Client.Types (

76 , HostConfig(..)

77 , defaultHostConfig

78 , NetworkingConfig(..)

79+ , NetworkScope(..)

80+ , CIDR(..)

81+ , IPAMDriver(..)

82+ , IPAMConfig(..)

83+ , IPAM(..)

84+ , NetworkContainer(..)

85+ , NetworkDetails(..)

86+ , NetworkType(..)

87+ , NetworkName

88+ , NetworkFilter(..)

79 , EndpointConfig(..)

89 , EndpointConfig(..)

80 , Ulimit(..)

90 , Ulimit(..)

81 , ContainerResources(..)

91 , ContainerResources(..)

@@ -114,6 +124,7 @@ import qualified Data.Text as T

114import Data.Time.Clock (UTCTime)

124import Data.Time.Clock (UTCTime)

115import qualified Data.Vector as V

125import qualified Data.Vector as V

116import GHC.Generics (Generic)

126import GHC.Generics (Generic)

127+import Numeric (readDec)

117import Prelude hiding (all, tail)

128import Prelude hiding (all, tail)

118import Text.Read (readMaybe)

129import Text.Read (readMaybe)

119

130

@@ -139,6 +150,8 @@ data Endpoint =

139 | DeleteImageEndpoint ImageDeleteOpts ImageID

150 | DeleteImageEndpoint ImageDeleteOpts ImageID

140 | CreateNetworkEndpoint CreateNetworkOpts

151 | CreateNetworkEndpoint CreateNetworkOpts

141 | RemoveNetworkEndpoint NetworkID

152 | RemoveNetworkEndpoint NetworkID

153+ | ListNetworksEndpoint [NetworkFilter]

154+ | InspectNetworkEndpoint NetworkID

142 deriving (Eq, Show)

155 deriving (Eq, Show)

143

156

144-- | We should newtype this

157-- | We should newtype this

@@ -858,6 +871,154 @@ instance ToJSON CreateNetworkOpts where

858 , "EnableIPv6" .= createNetworkEnableIPv6 opts

871 , "EnableIPv6" .= createNetworkEnableIPv6 opts

859 ]

872 ]

860

873

874+data NetworkScope = LocalScope | GlobalScope | SwarmScope deriving (Eq, Show)

875+

876+fromNetworkScope :: NetworkScope -> Text

877+fromNetworkScope LocalScope = "local"

878+fromNetworkScope GlobalScope = "global"

879+fromNetworkScope SwarmScope = "swarm"

880+

881+instance ToJSON NetworkScope where

882+ toJSON = JSON.String . fromNetworkScope

883+

884+instance FromJSON NetworkScope where

885+ parseJSON "local" = return LocalScope

886+ parseJSON "global" = return GlobalScope

887+ parseJSON "swarm" = return SwarmScope

888+ parseJSON _ = fail "Failed to parse NetworkScope"

889+

890+data CIDR = CIDR Text Int deriving (Eq, Show)

891+

892+instance FromJSON CIDR where

893+ parseJSON (JSON.String t) = case T.splitOn "/" t of

894+ [a,p] -> CIDR a <$> parsePrefixLen p

895+ _ -> fail "Failed to parse CIDR"

896+ where

897+ parsePrefixLen p = case readDec (T.unpack p) of

898+ (n,""):_ -> return n

899+ _ -> fail "Failed to parse CIDR prefix length"

900+ parseJSON _ = fail "Failed to parse CIDR"

901+

902+data IPAMDriver = DefaultIPAMDriver | NamedIPAMDriver Text deriving (Eq, Show)

903+

904+instance FromJSON IPAMDriver where

905+ parseJSON (JSON.String "default") = return DefaultIPAMDriver

906+ parseJSON (JSON.String t) = return $ NamedIPAMDriver t

907+ parseJSON _ = fail "IPAMDriver is not a string"

908+

909+data IPAMConfig = IPAMConfig

910+ { ipamConfigSubnet :: CIDR

911+ , ipamConfigIPRange :: Maybe CIDR

912+ , ipamSubnetGateway :: Maybe Text

913+ , ipamConfigAuxAddress :: Maybe Text

914+ } deriving (Eq, Show)

915+

916+instance FromJSON IPAMConfig where

917+ parseJSON (JSON.Object o) = IPAMConfig

918+ <$> o .: "Subnet"

919+ <*> o .:? "IPRange"

920+ <*> o .:? "Gateway"

921+ <*> o .:? "AuxAddress"

922+ parseJSON _ = fail "IPAMConfig is not an object"

923+

924+data IPAM = IPAM

925+ { ipamDriver :: IPAMDriver

926+ , ipamConfig :: [IPAMConfig]

927+ , ipamOptions :: HM.HashMap Text Text

928+ } deriving (Eq, Show)

929+

930+instance FromJSON IPAM where

931+ parseJSON (JSON.Object o) = IPAM

932+ <$> o .:? "Driver" .!= DefaultIPAMDriver

933+ <*> o .:? "Config" .!= []

934+ <*> o .:? "Options" .!= HM.empty

935+ parseJSON _ = fail "IPAM is not an object"

936+

937+data NetworkContainer = NetworkContainer

938+ { networkContainerName :: ContainerName

939+ , networkContainerEndpointID :: Text

940+ , networkContainerMacAddress :: Text

941+ , networkContainerIPv4Address :: Text

942+ , networkContainerIPv6Address :: Text

943+ } deriving (Eq, Show)

944+

945+instance FromJSON NetworkContainer where

946+ parseJSON (JSON.Object o) = NetworkContainer

947+ <$> o .: "Name"

948+ <*> o .: "EndpointID"

949+ <*> o .: "MacAddress"

950+ <*> o .: "IPv4Address"

951+ <*> o .: "IPv6Address"

952+ parseJSON _ = fail "NetworkContainer is not an object"

953+

954+data NetworkDetails = NetworkDetails

955+ { networkDetailsName :: Text

956+ , networkDetailsID :: NetworkID

957+ , networkDetailsCreated :: UTCTime

958+ , networkDetailsScope :: NetworkScope

959+ , networkDetailsDriver :: NetworkMode

960+ , networkDetailsEnableIPv6 :: Bool

961+ , networkDetailsInternal :: Bool

962+ , networkDetailsAttachable :: Bool

963+ , networkDetailsIngress :: Bool

964+ , networkDetailsIPAM :: IPAM

965+ , networkDetailsOptions :: HM.HashMap Text Text

966+ , networkDetailsLabels :: HM.HashMap Text Text

967+ , networkDetailsContainers :: HM.HashMap Text NetworkContainer

968+ } deriving (Eq, Show)

969+

970+instance FromJSON NetworkDetails where

971+ parseJSON v@(JSON.Object o) = NetworkDetails

972+ <$> o .: "Name"

973+ <*> parseJSON v

974+ <*> o .: "Created"

975+ <*> o .: "Scope"

976+ <*> o .: "Driver"

977+ <*> o .: "EnableIPv6"

978+ <*> o .: "Internal"

979+ <*> o .: "Attachable"

980+ <*> o .: "Ingress"

981+ <*> o .: "IPAM"

982+ <*> o .:? "Options" .!= HM.empty

983+ <*> o .:? "Labels" .!= HM.empty

984+ <*> o .:? "Containers" .!= HM.empty

985+ parseJSON _ = fail "NetworkDetails is not an object"

986+

987+data NetworkType = BuiltinNetwork | CustomNetwork deriving (Eq, Show)

988+

989+fromNetworkType :: NetworkType -> Text

990+fromNetworkType BuiltinNetwork = "builtin"

991+fromNetworkType CustomNetwork = "custom"

992+

993+type NetworkName = Text

994+

995+instance ToJSON NetworkType where

996+ toJSON = JSON.String . fromNetworkType

997+

998+instance FromJSON NetworkType where

999+ parseJSON (JSON.String "builtin") = return BuiltinNetwork

1000+ parseJSON (JSON.String "custom") = return CustomNetwork

1001+ parseJSON _ = fail "Failed to parse NetworkType"

1002+

1003+data NetworkFilter

1004+ = NetworkFilterName Text

1005+ | NetworkFilterID NetworkID

1006+ | NetworkFilterLabel Text

1007+ | NetworkFilterDriver NetworkMode

1008+ | NetworkFilterScope NetworkScope

1009+ | NetworkFilterType NetworkType

1010+ deriving (Eq, Show)

1011+

1012+instance {-# OVERLAPPING #-} ToJSON [NetworkFilter] where

1013+ toJSON = object . fmap toKV

1014+ where

1015+ toKV (NetworkFilterName n) = "name" .= [n]

1016+ toKV (NetworkFilterID i) = "id" .= [fromNetworkID i]

1017+ toKV (NetworkFilterLabel l) = "label" .= [l]

1018+ toKV (NetworkFilterDriver d) = "driver" .= [fromNetworkMode d]

1019+ toKV (NetworkFilterScope s) = "scope" .= [fromNetworkScope s]

1020+ toKV (NetworkFilterType t) = "type" .= [fromNetworkType t]

1021+

861-- TOOD: Add support for SELinux Volume labels (eg. "ro,z" or "ro/Z")

1022-- TOOD: Add support for SELinux Volume labels (eg. "ro,z" or "ro/Z")

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

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

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

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

@@ -1027,11 +1188,14 @@ instance FromJSON NetworkMode where

1027 parseJSON (JSON.String n) = return $ NetworkNamed n

1188 parseJSON (JSON.String n) = return $ NetworkNamed n

1028 parseJSON _ = fail "Unknown NetworkMode"

1189 parseJSON _ = fail "Unknown NetworkMode"

1029

1190

1191+fromNetworkMode :: NetworkMode -> Text

1192+fromNetworkMode NetworkBridge = "bridge"

1193+fromNetworkMode NetworkHost = "host"

1194+fromNetworkMode NetworkDisabled = "none"

1195+fromNetworkMode (NetworkNamed n) = n

1196+

1030instance ToJSON NetworkMode where

1197instance ToJSON NetworkMode where

1031− toJSON NetworkBridge = JSON.String "bridge"

1198+ toJSON = JSON.String . fromNetworkMode

1032− toJSON NetworkHost = JSON.String "host"

1033− toJSON NetworkDisabled = JSON.String "none"

1034− toJSON (NetworkNamed n) = JSON.String n

1035

1199

1036newtype NetworkID = NetworkID Text

1200newtype NetworkID = NetworkID Text

1037 deriving (Eq, Show)

1201 deriving (Eq, Show)

tests/tests.hs+16

@@ -144,6 +144,21 @@ testCreateRemoveNetwork = do

144 removeStatus <- removeNetwork nid

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

146

147+testListNetworks :: IO ()

148+testListNetworks =

149+ runDocker $ do

150+ res <- listNetworks [NetworkFilterName "bridge"]

151+ lift $ case res of

152+ Left _ -> assertFailure $ "listing networks, unexpected status: " ++ show res

153+ Right (d:_) -> assertBool "listing networks, bridge network missing" $ networkDetailsName d == "bridge"

154+

155+testInspectNetwork :: IO ()

156+testInspectNetwork =

157+ runDocker $ do

158+ res <- inspectNetwork . fromJust $ toNetworkID "bridge"

159+ lift $ assertBool ("inspecting networks, unewxpected status: " ++ show res) $ isRight res

160+

161+

147testLogDriverOptionsJson :: TestTree

162testLogDriverOptionsJson :: TestTree

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

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

149 where

164 where

@@ -249,6 +264,7 @@ integrationTests =

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

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

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

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

251 , testCase "Create and remove a network" testCreateRemoveNetwork

266 , testCase "Create and remove a network" testCreateRemoveNetwork

267+ , testCase "List networks" testListNetworks

252 ]

268 ]

253

269

254jsonTests :: TestTree

270jsonTests :: TestTree