Network and address pool (again)

Implementation of the network objects and address pool. Functionality
as in the reverted commit b9a616e1, 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

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

htest/Test/Ganeti/Network.hs

+{-# 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
+  ]
+

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
   ]

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

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

htools/Ganeti/Network.hs

+{-| 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 '.'
+

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
+