From 76a0266e2c0319b7d4a147224c328047441a9d54 Mon Sep 17 00:00:00 2001
From: Helga Velroyen <helgav@google.com>
Date: Mon, 10 Dec 2012 11:36:27 +0100
Subject: [PATCH] Network and address pool (again)
Implementation of the network objects and address pool. Functionality
as in the reverted commit b9a616e132af9bba718d2da8c94eeec7af886814, but
now using only the vector library and not the bit-vector library.
Tested with vector library version 0.9 and 0.10., which are
also installed on the buildbot machines now.
Signed-off-by: Helga Velroyen <helgav@google.com>
Reviewed-by: Iustin Pop <iustin@google.com>
---
Makefile.am | 2 +
htest/Test/Ganeti/Network.hs | 169 ++++++++++++++++++++++++++++
htest/Test/Ganeti/Objects.hs | 35 ++++++
htest/Test/Ganeti/Query/Language.hs | 1 +
htest/test.hs | 2 +
htools/Ganeti/Network.hs | 103 +++++++++++++++++
htools/Ganeti/Objects.hs | 37 ++++++
7 files changed, 349 insertions(+)
create mode 100644 htest/Test/Ganeti/Network.hs
create mode 100644 htools/Ganeti/Network.hs
diff --git a/Makefile.am b/Makefile.am
index 08f1e5b71..3255e2a91 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 000000000..99353a202
--- /dev/null
+++ b/htest/Test/Ganeti/Network.hs
@@ -0,0 +1,169 @@
+{-# 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.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 (V.Vector Bool)
+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 :: V.Vector Bool -> V.Vector Bool -> Bool
+bitVectorSubsumes v1 v2 = V.and $
+ V.zipWith (\a b -> not b || a) 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 66b704299..7e3e9919f 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 01a96d520..7934edb52 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 486b0a906..0a31d3dcc 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 000000000..45168bc91
--- /dev/null
+++ b/htools/Ganeti/Network.hs
@@ -0,0 +1,103 @@
+{-| 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.Unboxed as V
+
+import Ganeti.Objects
+
+data AddressPool = AddressPool { network :: Network,
+ reservations :: V.Vector Bool,
+ extReservations :: V.Vector Bool }
+ 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 -> V.Vector Bool
+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 -> V.Vector Bool
+bitStringToBitVector = V.fromList . map (/= '0')
+
+-- | Get a bit vector of all reservations (internal and external) combined.
+allReservations :: AddressPool -> V.Vector Bool
+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 a3e9980d8..18ca6dfe1 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
+
--
GitLab