.. in Haskell and work with BitArrays directly. Having a separate data type AdderssPool doesn't help, as it should be always present; if a network doesn't have the table of reservations we want to add the table anyway. (Unlike in Python, where AddressPool modifies its corresponding Network object.)
Add functions for making reservations on a Network object. Signed-off-by: Petr Pudlak <[email protected]> --- src/Ganeti/Constants.hs | 13 +++ src/Ganeti/Network.hs | 220 ++++++++++++++++++++++++++++++----------- src/Ganeti/Objects.hs | 8 +- src/Ganeti/Query/Network.hs | 8 +- test/hs/Test/Ganeti/Network.hs | 100 +++++-------------- test/hs/Test/Ganeti/Objects.hs | 12 +-- 6 files changed, 215 insertions(+), 146 deletions(-) diff --git a/src/Ganeti/Constants.hs b/src/Ganeti/Constants.hs index 832c86c..7761f7d 100644 --- a/src/Ganeti/Constants.hs +++ b/src/Ganeti/Constants.hs @@ -5009,3 +5009,16 @@ helperVmShutdown = 2 * 60 * 60 -- speed of 1/5 of the max speed of current drives. zeroingTimeoutPerMib :: Double zeroingTimeoutPerMib = 1.0 / (100.0 / 5.0) + +-- * Networking + +-- The minimum size of a network. +ipv4NetworkMinSize :: Int +ipv4NetworkMinSize = 30 + +-- The maximum size of a network. +-- +-- FIXME: This limit is for performance reasons. Remove when refactoring +-- for performance tuning was successful. +ipv4NetworkMaxSize :: Int +ipv4NetworkMaxSize = 30 diff --git a/src/Ganeti/Network.hs b/src/Ganeti/Network.hs index 5106213..832cba0 100644 --- a/src/Ganeti/Network.hs +++ b/src/Ganeti/Network.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RankNTypes #-} + {-| Implementation of the Ganeti network objects. This is does not (yet) cover all methods that are provided in the @@ -27,79 +29,183 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -} module Ganeti.Network - ( AddressPool(..) - , createAddressPool - , bitStringToBitVector - , allReservations + ( PoolPart(..) + , netIpv4NumHosts , getReservedCount , getFreeCount , isFull , getMap - , networkIsValid + , isReserved + , reserve + , release + , findFree + , allReservations + , reservations + , extReservations ) where -import qualified Data.Vector.Unboxed as V +import Control.Monad +import Control.Monad.Error +import Control.Monad.State +import Data.Function (on) +import Ganeti.BasicTypes +import qualified Ganeti.Constants as C +import Ganeti.Lens import Ganeti.Objects +import Ganeti.Objects.Lens +import qualified Ganeti.Objects.BitArray as BA --- | An address pool, holding a network plus internal and external --- reservations. -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') +ipv4NumHosts :: (Integral n) => n -> Integer +ipv4NumHosts mask = 2^(32 - mask) + +ipv4NetworkMinNumHosts :: Integer +ipv4NetworkMinNumHosts = ipv4NumHosts C.ipv4NetworkMinSize + +ipv4NetworkMaxNumHosts :: Integer +ipv4NetworkMaxNumHosts = ipv4NumHosts C.ipv4NetworkMaxSize + +data PoolPart = PoolInstances | PoolExt + +poolLens :: PoolPart -> Lens' Network (Maybe BA.BitArray) +poolLens PoolInstances = networkReservationsL +poolLens PoolExt = networkExtReservationsL + +netIpv4NumHosts :: Network -> Integer +netIpv4NumHosts = ipv4NumHosts . ip4netMask . networkNetwork + +-- | Creates a new bit array pool of the appropriate size +newPool :: (MonadError e m, Error e) => Network -> m BA.BitArray +newPool net = do + let numhosts = netIpv4NumHosts net + when (numhosts > ipv4NetworkMaxNumHosts) . failError $ + "A big network with " ++ show numhosts ++ " host(s) is currently" + ++ " not supported, please specify at most a /" + ++ show ipv4NetworkMaxNumHosts ++ " network" + when (numhosts < ipv4NetworkMinNumHosts) . failError $ + "A network with only " ++ show numhosts ++ " host(s) is too small," + ++ " please specify at least a /" + ++ show ipv4NetworkMinNumHosts ++ " network" + return $ BA.zeroes (fromInteger numhosts) + +-- | A helper function that creates a bit array pool, of it's missing. +orNewPool :: (MonadError e m, Error e) + => Network -> Maybe BA.BitArray -> m BA.BitArray +orNewPool net = maybe (newPool net) return + +withPool :: (MonadError e m, Error e) + => PoolPart -> (Network -> BA.BitArray -> m (a, BA.BitArray)) + -> StateT Network m a +withPool part f = StateT $ \n -> mapMOf2 (poolLens part) (f' n) n + where + f' net = liftM (over _2 Just) . f net <=< orNewPool net + +withPool_ :: (MonadError e m, Error e) + => PoolPart -> (Network -> BA.BitArray -> m BA.BitArray) + -> Network -> m Network +withPool_ part f = execStateT $ withPool part ((liftM ((,) ()) .) . f) + +readPool :: PoolPart -> Network -> Maybe BA.BitArray +readPool = view . poolLens + +readPoolE :: (MonadError e m, Error e) + => PoolPart -> Network -> m BA.BitArray +readPoolE part net = orNewPool net (readPool part net) + +readAllE :: (MonadError e m, Error e) + => Network -> m BA.BitArray +readAllE net = do + res <- orNewPool net $ networkReservations net + ext <- orNewPool net $ networkExtReservations net + return $ res BA.-|- ext + +reservations :: Network -> Maybe BA.BitArray +reservations = readPool PoolInstances + +extReservations :: Network -> Maybe BA.BitArray +extReservations = readPool PoolExt -- | Get a bit vector of all reservations (internal and external) combined. -allReservations :: AddressPool -> V.Vector Bool -allReservations a = V.zipWith (||) (reservations a) (extReservations a) +allReservations :: Network -> Maybe BA.BitArray +allReservations a = (BA.-|-) `liftM` reservations a `ap` extReservations a -- | Get the count of reserved addresses. -getReservedCount :: AddressPool -> Int -getReservedCount = V.length . V.filter (== True) . allReservations +getReservedCount :: Network -> Int +getReservedCount = maybe 0 BA.count1 . allReservations -- | Get the count of free addresses. -getFreeCount :: AddressPool -> Int -getFreeCount = V.length . V.filter (== False) . allReservations +getFreeCount :: Network -> Int +getFreeCount = maybe 0 BA.count0 . allReservations -- | Check whether the network is full. -isFull :: AddressPool -> Bool -isFull = V.and . allReservations +isFull :: Network -> Bool +isFull = (0 ==) . getFreeCount -- | 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 '.' +getMap :: Network -> String +getMap = maybe "" (BA.asString '.' 'X') . allReservations + +-- * Functions used for manipulating the reservations + +-- | Returns an address index wrt a network. +-- Fails if the address isn't in the network range. +addrIndex :: (MonadError e m, Error e) => Ip4Address -> Network -> m Int +addrIndex addr net = do + let n = networkNetwork net + i = on (-) ip4AddressToNumber addr (ip4netAddr n) + when ((i < 0) || (i >= ipv4NumHosts (ip4netMask n))) . failError + $ "Address '" ++ show addr ++ "' not in the network '" ++ show net ++ "'" + return $ fromInteger i + +-- | Returns an address of a given index wrt a network. +-- Fails if the index isn't in the network range. +addrAt :: (MonadError e m, Error e) => Int -> Network -> m Ip4Address +addrAt i net | (i' < 0) || (i' >= ipv4NumHosts (ip4netMask n)) = + failError $ "Requested index " ++ show i + ++ " outside the range of network '" ++ show net ++ "'" + | otherwise = + return $ ip4AddressFromNumber (ip4AddressToNumber (ip4netAddr n) + i') + where + n = networkNetwork net + i' = toInteger i + +-- | Checks if a given address is reserved. +-- Fails if the address isn't in the network range. +isReserved :: (MonadError e m, Error e) => + PoolPart -> Ip4Address -> Network -> m Bool +isReserved part addr net = + (BA.!) `liftM` readPoolE part net `ap` addrIndex addr net + +-- | Marks an address as used. +reserve :: (MonadError e m, Error e) => + PoolPart -> Ip4Address -> Network -> m Network +reserve part addr = + withPool_ part $ \net ba -> do + idx <- addrIndex addr net + let addrs = show addr + when (ba BA.! idx) . failError $ case part of + PoolExt -> "IP " ++ addrs ++ " is already externally reserved" + PoolInstances -> "IP " ++ addrs ++ " is already used by an instance" + BA.setAt idx True ba + +-- | Marks an address as unused. +release :: (MonadError e m, Error e) => + PoolPart -> Ip4Address -> Network -> m Network +release part addr = + withPool_ part $ \net ba -> do + idx <- addrIndex addr net + let addrs = show addr + unless (ba BA.! idx) . failError $ case part of + PoolExt -> "IP " ++ addrs ++ " is not externally reserved" + PoolInstances -> "IP " ++ addrs ++ " is not used by an instance" + BA.setAt idx False ba + +-- | Get the first free address in the network +-- that satisfies a given predicate. +findFree :: (MonadError e m, Error e) + => (Ip4Address -> Bool) -> Network -> m (Maybe Ip4Address) +findFree p net = readAllE net >>= BA.foldr f (return Nothing) + where + addrAtEither = addrAt :: Int -> Network -> Either String Ip4Address + f False i _ | Right a <- addrAtEither i net, p a = return (Just a) + f _ _ x = x diff --git a/src/Ganeti/Objects.hs b/src/Ganeti/Objects.hs index 730a39b..1817537 100644 --- a/src/Ganeti/Objects.hs +++ b/src/Ganeti/Objects.hs @@ -120,6 +120,7 @@ import qualified AutoConf import qualified Ganeti.Constants as C import qualified Ganeti.ConstantUtils as ConstantUtils import Ganeti.JSON +import qualified Ganeti.Objects.BitArray as BA import Ganeti.Types import Ganeti.THH import Ganeti.THH.Field @@ -241,6 +242,9 @@ instance JSON Ip4Network where -- FIXME: Not all types might be correct here, since they -- haven't been exhaustively deduced from the python code yet. +-- +-- FIXME: When parsing, check that the ext_reservations and reservations +-- have the same length $(buildObject "Network" "network" $ [ simpleField "name" [t| NonEmptyString |] , optionalField $ @@ -253,9 +257,9 @@ $(buildObject "Network" "network" $ , optionalField $ simpleField "gateway6" [t| String |] , optionalField $ - simpleField "reservations" [t| String |] + simpleField "reservations" [t| BA.BitArray |] , optionalField $ - simpleField "ext_reservations" [t| String |] + simpleField "ext_reservations" [t| BA.BitArray |] ] ++ uuidFields ++ timeStampFields diff --git a/src/Ganeti/Query/Network.hs b/src/Ganeti/Query/Network.hs index 3a4a31b..19bf140 100644 --- a/src/Ganeti/Query/Network.hs +++ b/src/Ganeti/Query/Network.hs @@ -61,14 +61,14 @@ networkFields = FieldSimple (rsMaybeUnavail . networkMacPrefix), QffNormal) , (FieldDefinition "free_count" "FreeCount" QFTNumber "Number of available\ \ addresses", - FieldSimple (rsMaybeNoData . fmap getFreeCount . createAddressPool), + FieldSimple (rsNormal . getFreeCount), QffNormal) , (FieldDefinition "map" "Map" QFTText "Actual mapping", - FieldSimple (rsMaybeNoData . fmap getMap . createAddressPool), + FieldSimple (rsNormal . getMap), QffNormal) , (FieldDefinition "reserved_count" "ReservedCount" QFTNumber "Number of reserved addresses", - FieldSimple (rsMaybeNoData . fmap getReservedCount . createAddressPool), + FieldSimple (rsNormal . getReservedCount), QffNormal) , (FieldDefinition "group_list" "GroupList" QFTOther "List of nodegroups (group name, NIC mode, NIC link)", @@ -175,5 +175,5 @@ getReservations net = getExtReservationsString :: Network -> ResultEntry getExtReservationsString net = let addrs = getReservations (networkNetwork net) - (fromMaybe "" $ networkExtReservations net) + (maybe "" show $ networkExtReservations net) in rsNormal . intercalate ", " $ map show addrs diff --git a/test/hs/Test/Ganeti/Network.hs b/test/hs/Test/Ganeti/Network.hs index 57793ca..58fee6f 100644 --- a/test/hs/Test/Ganeti/Network.hs +++ b/test/hs/Test/Ganeti/Network.hs @@ -6,72 +6,22 @@ module Test.Ganeti.Network , genBitStringMaxLen ) where +import Data.Maybe (fromMaybe) + import Test.QuickCheck import Ganeti.Network as Network import Ganeti.Objects as Objects +import Ganeti.Objects.BitArray as BA -import Test.Ganeti.Objects - ( genBitStringMaxLen - , genValidNetwork ) -import Test.Ganeti.TestHelper +import Test.Ganeti.Objects ( genBitStringMaxLen ) import Test.Ganeti.TestCommon - -import qualified Data.Vector.Unboxed as V - --- * Generators and arbitrary instances - --- | 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 - -- Generating networks with netmask of minimum /24 to avoid too long - -- bit strings being generated. - net <- genValidNetwork - lenBitVec <- choose (0, maxLenBitVec) - res <- genBitVector lenBitVec - ext_res <- genBitVector lenBitVec - return AddressPool { network = net - , reservations = res - , extReservations = ext_res } - --- | 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 - -instance Arbitrary AddressPool where - arbitrary = genAddressPool ((2::Int)^(8::Int)) +import Test.Ganeti.TestHelper -- * 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 :: Network -> Property prop_addressPoolProperties a = conjoin [ printTestCase @@ -93,40 +43,38 @@ prop_addressPoolProperties a = show a) (checkGetMap a) ] +-- | Checks for the subset relation on 'Maybe' values. +subsetMaybe :: Maybe BitArray -> Maybe BitArray -> Bool +subsetMaybe (Just x) (Just y) = subset x y +subsetMaybe x y = x == y -- only if they're both Nothing + -- | Check that all internally reserved ips are included in 'allReservations'. -allReservationsSubsumesInternal :: AddressPool -> Bool +allReservationsSubsumesInternal :: Network -> Bool allReservationsSubsumesInternal a = - bitVectorSubsumes (allReservations a) (reservations a) + reservations a `subsetMaybe` allReservations a -- | Check that all externally reserved ips are included in 'allReservations'. -allReservationsSubsumesExternal :: AddressPool -> Bool +allReservationsSubsumesExternal :: Network -> 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 + extReservations a `subsetMaybe` allReservations a -- | Check that the counts of free and reserved ips add up. -checkCounts :: AddressPool -> Bool +checkCounts :: Network -> Property checkCounts a = - let res = reservations a - in V.length res == getFreeCount a + getReservedCount a + netIpv4NumHosts a ==? toInteger (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) +checkIsFull :: Network -> Property +checkIsFull a = + isFull a ==? maybe True (and . toList) (allReservations a) -- | Check that the map representation of the network corresponds to the -- network's reservations. -checkGetMap :: AddressPool -> Bool +checkGetMap :: Network -> Property checkGetMap a = - allReservations a == V.fromList (Prelude.map (== 'X') (getMap a)) + fromMaybe BA.empty (allReservations a) + ==? fromList (Prelude.map (== 'X') (getMap a)) testSuite "Network" - [ 'prop_bitStringToBitVector - , 'prop_createAddressPool - , 'prop_addressPoolProperties + [ 'prop_addressPoolProperties ] - diff --git a/test/hs/Test/Ganeti/Objects.hs b/test/hs/Test/Ganeti/Objects.hs index 8377a31..f3c224f 100644 --- a/test/hs/Test/Ganeti/Objects.hs +++ b/test/hs/Test/Ganeti/Objects.hs @@ -61,6 +61,7 @@ import Test.Ganeti.Types () import qualified Ganeti.Constants as C import Ganeti.Network import Ganeti.Objects as Objects +import qualified Ganeti.Objects.BitArray as BA import Ganeti.JSON import Ganeti.Types @@ -283,12 +284,12 @@ genValidNetwork = do return n -- | Generate an arbitrary string consisting of '0' and '1' of the given length. -genBitString :: Int -> Gen String -genBitString len = vectorOf len (elements "01") +genBitString :: Int -> Gen BA.BitArray +genBitString len = BA.fromList `liftM` vectorOf len (elements [False, True]) -- | Generate an arbitrary string consisting of '0' and '1' of the maximum given -- length. -genBitStringMaxLen :: Int -> Gen String +genBitStringMaxLen :: Int -> Gen BA.BitArray genBitStringMaxLen maxLen = choose (0, maxLen) >>= genBitString -- | Generator for config data with an empty cluster (no instances), @@ -448,10 +449,7 @@ casePyCompatNetworks = do -- to be compared against the same properties generated by the python code. getNetworkProperties :: Network -> (Int, Int, Network) getNetworkProperties net = - let maybePool = createAddressPool net - in case maybePool of - (Just pool) -> (getFreeCount pool, getReservedCount pool, net) - Nothing -> (-1, -1, net) + (getFreeCount net, getReservedCount net, net) -- | Tests the compatibility between Haskell-serialized node groups and their -- python-decoded and encoded version. -- 2.0.0.526.g5318336
