diff --git a/Makefile.am b/Makefile.am
index 6c2275bd9da9d9b27bed827ba64b9d12bdbc2055..86e41141b0706d3f04cacd63c477d2e3ea7ba97f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -481,6 +481,7 @@ HS_LIB_SRCS = \
htools/Ganeti/Jobs.hs \
htools/Ganeti/Logging.hs \
htools/Ganeti/Luxi.hs \
+ htools/Ganeti/Network.hs \
htools/Ganeti/Objects.hs \
htools/Ganeti/OpCodes.hs \
htools/Ganeti/OpParams.hs \
@@ -523,6 +524,7 @@ HS_TEST_SRCS = \
htest/Test/Ganeti/JSON.hs \
htest/Test/Ganeti/Jobs.hs \
htest/Test/Ganeti/Luxi.hs \
+ htest/Test/Ganeti/Network.hs \
htest/Test/Ganeti/Objects.hs \
htest/Test/Ganeti/OpCodes.hs \
htest/Test/Ganeti/Query/Filter.hs \
diff --git a/htest/Test/Ganeti/Network.hs b/htest/Test/Ganeti/Network.hs
new file mode 100644
index 0000000000000000000000000000000000000000..085b92c486cdb88992e474c9f06bbe5bfd8d03e6
--- /dev/null
+++ b/htest/Test/Ganeti/Network.hs
@@ -0,0 +1,170 @@
+{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Test.Ganeti.Network
+ ( testNetwork
+ ) where
+
+import Test.QuickCheck
+
+import Control.Monad
+
+import Ganeti.Network as Network
+import Ganeti.Objects as Objects
+import Ganeti.Types
+
+import Test.Ganeti.Query.Language (genJSValue)
+import Test.Ganeti.TestHelper
+import Test.Ganeti.TestCommon
+
+import qualified Data.Vector.Bit as B
+import qualified Data.Vector.Unboxed as V
+import qualified Data.Set as S
+
+-- * Generators and arbitrary instances
+
+-- | Generate an arbitrary string consisting of '0' and '1' of the given length.
+genBitString :: Int -> Gen String
+genBitString len = vectorOf len (elements "01")
+
+-- | Generate an arbitrary string consisting of '0' and '1' of the maximum given
+-- length.
+genBitStringMaxLen :: Int -> Gen String
+genBitStringMaxLen maxLen = choose (0, maxLen) >>= genBitString
+
+-- | Generates an arbitrary bit vector of the given length.
+genBitVector :: Int -> Gen B.BitVector
+genBitVector len = do
+ boolList <- vector len::Gen [Bool]
+ return $ V.fromList boolList
+
+-- | Generates a network instance with bit vectors of the given lengths for
+-- reservations and external reservations.
+genValidNetwork :: Int -> Gen Objects.Network
+genValidNetwork maxLenBitStr = do
+ lenBitStr <- choose (0, maxLenBitStr)
+ name <- genName >>= mkNonEmpty
+ network_type <- genMaybe genNetworkType
+ mac_prefix <- genMaybe genName
+ family <- arbitrary
+ net <- genName >>= mkNonEmpty
+ net6 <- genMaybe genName
+ gateway <- genMaybe genName
+ gateway6 <- genMaybe genName
+ size <- genMaybe genJSValue
+ res <- liftM Just (genBitString lenBitStr)
+ ext_res <- liftM Just (genBitString lenBitStr)
+ let n = Network name network_type mac_prefix family net net6 gateway
+ gateway6 size res ext_res 0 S.empty
+ return n
+
+-- | Generates an arbitrary network type.
+genNetworkType :: Gen NetworkType
+genNetworkType = elements [ PrivateNetwork, PublicNetwork ]
+
+-- | Network instances are generated arbitrarily only with short bit strings to
+-- not slow down the test execution too much.
+instance Arbitrary Objects.Network where
+ arbitrary = genValidNetwork 256
+
+-- | Generates address pools. The size of the network is intentionally
+-- decoupled from the size of the bit vectors, to avoid slowing down
+-- the tests by generating unnecessary bit strings.
+genAddressPool :: Int -> Gen AddressPool
+genAddressPool maxLenBitVec = do
+ net <- arbitrary
+ lenBitVec <- choose (0, maxLenBitVec)
+ res <- genBitVector lenBitVec
+ ext_res <- genBitVector lenBitVec
+ return AddressPool { network = net
+ , reservations = res
+ , extReservations = ext_res }
+
+instance Arbitrary AddressPool where
+ arbitrary = genAddressPool ((2::Int)^(8::Int))
+
+-- * Test cases
+
+-- | Check the mapping of bit strings to bit vectors
+prop_bitStringToBitVector :: Property
+prop_bitStringToBitVector =
+ forAll (genBitStringMaxLen 256) $ \bs ->
+ let bitList = V.toList $ Network.bitStringToBitVector bs
+ bitCharList = Prelude.zip bitList bs
+ in Prelude.all checkBit bitCharList
+
+-- | Check whether an element of a bit vector is consistent with an element
+-- of a bit string (containing '0' and '1' characters).
+checkBit :: (Bool, Char) -> Bool
+checkBit (False, '0') = True
+checkBit (True, '1') = True
+checkBit _ = False
+
+-- | Check creation of an address pool when a network is given.
+prop_createAddressPool :: Objects.Network -> Property
+prop_createAddressPool n =
+ let valid = networkIsValid n
+ in case createAddressPool n of
+ Just _ -> True ==? valid
+ Nothing -> False ==? valid
+
+-- | Check that the address pool's properties are calculated correctly.
+prop_addressPoolProperties :: AddressPool -> Property
+prop_addressPoolProperties a =
+ conjoin
+ [ printTestCase
+ ("Not all reservations are included in 'allReservations' of " ++
+ "address pool:" ++ show a) (allReservationsSubsumesInternal a)
+ , printTestCase
+ ("Not all external reservations are covered by 'allReservations' " ++
+ "of address pool: " ++ show a)
+ (allReservationsSubsumesExternal a)
+ , printTestCase
+ ("The counts of free and reserved addresses do not add up for " ++
+ "address pool: " ++ show a)
+ (checkCounts a)
+ , printTestCase
+ ("'isFull' wrongly classified the status of the address pool: " ++
+ show a) (checkIsFull a)
+ , printTestCase
+ ("Network map is inconsistent with reservations of address pool: " ++
+ show a) (checkGetMap a)
+ ]
+
+-- | Check that all internally reserved ips are included in 'allReservations'.
+allReservationsSubsumesInternal :: AddressPool -> Bool
+allReservationsSubsumesInternal a =
+ bitVectorSubsumes (allReservations a) (reservations a)
+
+-- | Check that all externally reserved ips are included in 'allReservations'.
+allReservationsSubsumesExternal :: AddressPool -> Bool
+allReservationsSubsumesExternal a =
+ bitVectorSubsumes (allReservations a) (extReservations a)
+
+-- | Checks if one bit vector subsumes the other one.
+bitVectorSubsumes :: B.BitVector -> B.BitVector -> Bool
+bitVectorSubsumes v1 v2 = V.and $
+ V.zipWith (\a b -> if b then a else True) v1 v2
+
+-- | Check that the counts of free and reserved ips add up.
+checkCounts :: AddressPool -> Bool
+checkCounts a =
+ let res = reservations a
+ in V.length res == getFreeCount a + getReservedCount a
+
+-- | Check that the detection of a full network works correctly.
+checkIsFull :: AddressPool -> Bool
+checkIsFull a = isFull a == V.notElem False (allReservations a)
+
+-- | Check that the map representation of the network corresponds to the
+-- network's reservations.
+checkGetMap :: AddressPool -> Bool
+checkGetMap a =
+ allReservations a == V.fromList (Prelude.map (== 'X') (getMap a))
+
+testSuite "Network"
+ [ 'prop_bitStringToBitVector
+ , 'prop_createAddressPool
+ , 'prop_addressPoolProperties
+ ]
+
diff --git a/htest/Test/Ganeti/Objects.hs b/htest/Test/Ganeti/Objects.hs
index 66b7042998828c463f9a9556c91bf6e712422217..7e3e9919f44a54811cbd4ee146a5a56430ab757b 100644
--- a/htest/Test/Ganeti/Objects.hs
+++ b/htest/Test/Ganeti/Objects.hs
@@ -38,6 +38,7 @@ import Control.Applicative
import qualified Data.Map as Map
import qualified Data.Set as Set
+import Test.Ganeti.Query.Language (genJSValue)
import Test.Ganeti.TestHelper
import Test.Ganeti.TestCommon
import Test.Ganeti.Types ()
@@ -162,6 +163,35 @@ instance Arbitrary TagSet where
$(genArbitrary ''Cluster)
+instance Arbitrary Network where
+ arbitrary = Network <$>
+ -- name
+ arbitrary
+ -- network_type
+ <*> arbitrary
+ -- mac_prefix
+ <*> arbitrary
+ -- family
+ <*> arbitrary
+ -- network
+ <*> arbitrary
+ -- network6
+ <*> arbitrary
+ -- gateway
+ <*> arbitrary
+ -- gateway6
+ <*> arbitrary
+ -- size
+ <*> genMaybe genJSValue
+ -- reservations
+ <*> arbitrary
+ -- external reservations
+ <*> arbitrary
+ -- serial
+ <*> arbitrary
+ -- tags
+ <*> (Set.fromList <$> genTags)
+
-- | Generator for config data with an empty cluster (no instances),
-- with N defined nodes.
genEmptyCluster :: Int -> Gen ConfigData
@@ -222,6 +252,10 @@ prop_Node_serialisation = testSerialisation
prop_Inst_serialisation :: Instance -> Property
prop_Inst_serialisation = testSerialisation
+-- | Check that network serialisation is idempotent.
+prop_Network_serialisation :: Network -> Property
+prop_Network_serialisation = testSerialisation
+
-- | Check config serialisation.
prop_Config_serialisation :: Property
prop_Config_serialisation =
@@ -231,6 +265,7 @@ testSuite "Objects"
[ 'prop_fillDict
, 'prop_Disk_serialisation
, 'prop_Inst_serialisation
+ , 'prop_Network_serialisation
, 'prop_Node_serialisation
, 'prop_Config_serialisation
]
diff --git a/htest/Test/Ganeti/Query/Language.hs b/htest/Test/Ganeti/Query/Language.hs
index 01a96d520549afa65ed21a8614a66d7512b1873d..7934edb52b39e1f45a6d3edd76a0d86d27f69bae 100644
--- a/htest/Test/Ganeti/Query/Language.hs
+++ b/htest/Test/Ganeti/Query/Language.hs
@@ -29,6 +29,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
module Test.Ganeti.Query.Language
( testQuery_Language
, genFilter
+ , genJSValue
) where
import Test.QuickCheck
diff --git a/htest/test.hs b/htest/test.hs
index 486b0a90655546574f839c7b640bf9bfade19517..0a31d3dcc5e11c2e81806b321348be4f6bc3bc64 100644
--- a/htest/test.hs
+++ b/htest/test.hs
@@ -52,6 +52,7 @@ import Test.Ganeti.HTools.Types
import Test.Ganeti.JSON
import Test.Ganeti.Jobs
import Test.Ganeti.Luxi
+import Test.Ganeti.Network
import Test.Ganeti.Objects
import Test.Ganeti.OpCodes
import Test.Ganeti.Query.Filter
@@ -100,6 +101,7 @@ allTests =
, testJSON
, testJobs
, testLuxi
+ , testNetwork
, testObjects
, testOpCodes
, testQuery_Filter
diff --git a/htools/Ganeti/Network.hs b/htools/Ganeti/Network.hs
new file mode 100644
index 0000000000000000000000000000000000000000..4c209f02cbeadf14467832596be818fe10732343
--- /dev/null
+++ b/htools/Ganeti/Network.hs
@@ -0,0 +1,104 @@
+{-| Implementation of the Ganeti network objects.
+
+This is does not (yet) cover all methods that are provided in the
+corresponding python implementation (network.py).
+
+-}
+
+{-
+
+Copyright (C) 2011, 2012 Google Inc.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.
+
+-}
+
+module Ganeti.Network
+ ( AddressPool(..)
+ , createAddressPool
+ , bitStringToBitVector
+ , allReservations
+ , getReservedCount
+ , getFreeCount
+ , isFull
+ , getMap
+ , networkIsValid
+ ) where
+
+import qualified Data.Vector.Bit as B
+import qualified Data.Vector.Unboxed as V
+
+import Ganeti.Objects
+
+data AddressPool = AddressPool { network :: Network,
+ reservations :: B.BitVector,
+ extReservations :: B.BitVector }
+ deriving (Show)
+
+-- | Create an address pool from a network.
+createAddressPool :: Network -> Maybe AddressPool
+createAddressPool n
+ | networkIsValid n =
+ let res = maybeStr2BitVec $ networkReservations n
+ ext_res = maybeStr2BitVec $ networkExtReservations n
+ in Just AddressPool { reservations = res
+ , extReservations = ext_res
+ , network = n }
+ | otherwise = Nothing
+
+-- | Checks the consistency of the network object. So far, only checks the
+-- length of the reservation strings.
+networkIsValid :: Network -> Bool
+networkIsValid n = sameLength (networkReservations n) (networkExtReservations n)
+
+-- | Checks if two maybe strings are both nothing or of equal length.
+sameLength :: Maybe String -> Maybe String -> Bool
+sameLength Nothing Nothing = True
+sameLength (Just s1) (Just s2) = length s1 == length s2
+sameLength _ _ = False
+
+-- | Converts a maybe bit string to a bit vector. Returns an empty bit vector on
+-- nothing.
+maybeStr2BitVec :: Maybe String -> B.BitVector
+maybeStr2BitVec (Just s) = bitStringToBitVector s
+maybeStr2BitVec Nothing = V.fromList ([]::[Bool])
+
+-- | Converts a string to a bit vector. The character '0' is interpreted
+-- as 'False', all others as 'True'.
+bitStringToBitVector :: String -> B.BitVector
+bitStringToBitVector = V.fromList . map (/= '0')
+
+-- | Get a bit vector of all reservations (internal and external) combined.
+allReservations :: AddressPool -> B.BitVector
+allReservations a = V.zipWith (||) (reservations a) (extReservations a)
+
+-- | Get the count of reserved addresses.
+getReservedCount :: AddressPool -> Int
+getReservedCount = V.length . V.filter (== True) . allReservations
+
+-- | Get the count of free addresses.
+getFreeCount :: AddressPool -> Int
+getFreeCount = V.length . V.filter (== False) . allReservations
+
+-- | Check whether the network is full.
+isFull :: AddressPool -> Bool
+isFull = V.and . allReservations
+
+-- | Return a textual representation of the network's occupation status.
+getMap :: AddressPool -> String
+getMap = V.toList . V.map mapPixel . allReservations
+ where mapPixel c = if c then 'X' else '.'
+
diff --git a/htools/Ganeti/Objects.hs b/htools/Ganeti/Objects.hs
index a3e9980d86f698cc12bb00e710a193f7b62bea03..18ca6dfe15ccc7e8b17d2896507d9aadc378b022 100644
--- a/htools/Ganeti/Objects.hs
+++ b/htools/Ganeti/Objects.hs
@@ -87,6 +87,7 @@ module Ganeti.Objects
, TagsObject(..)
, DictObject(..) -- re-exported from THH
, TagSet -- re-exported from THH
+ , Network(..)
) where
import Data.List (foldl')
@@ -590,3 +591,39 @@ $(buildObject "ConfigData" "config" $
instance SerialNoObject ConfigData where
serialOf = configSerial
+
+-- * Network definitions
+
+-- FIXME: Not all types might be correct here, since they
+-- haven't been exhaustively deduced from the python code yet.
+$(buildObject "Network" "network" $
+ [ simpleField "name" [t| NonEmptyString |]
+ , optionalField $
+ simpleField "network_type" [t| NetworkType |]
+ , optionalField $
+ simpleField "mac_prefix" [t| String |]
+ , optionalField $
+ simpleField "family" [t| Int |]
+ , simpleField "network" [t| NonEmptyString |]
+ , optionalField $
+ simpleField "network6" [t| String |]
+ , optionalField $
+ simpleField "gateway" [t| String |]
+ , optionalField $
+ simpleField "gateway6" [t| String |]
+ , optionalField $
+ simpleField "size" [t| J.JSValue |]
+ , optionalField $
+ simpleField "reservations" [t| String |]
+ , optionalField $
+ simpleField "ext_reservations" [t| String |]
+ ]
+ ++ serialFields
+ ++ tagsFields)
+
+instance SerialNoObject Network where
+ serialOf = networkSerial
+
+instance TagsObject Network where
+ tagsOf = networkTags
+