And add functions for making reservations on a Network object. Currently AddressPool is only a thin wrapper for BitArray, because:
- all operations need information from Network about the allowed address range; and - having richer structure in AddressPool would require changes in the configuration format. Signed-off-by: Petr Pudlak <[email protected]> --- As discussed, I kept the AddressPool object, but currently its just a thin wrapper around BitArray. More refactoring (such as AddressPool containing the network range) would require configuration changes, and I'd rather leave it until later, when the new structure of IP addresses wrt subnets and pools is going to be implemented. (I can help with this particular Haskell 'Network' module, if needed.) src/Ganeti/Constants.hs | 13 +++ src/Ganeti/Network.hs | 234 +++++++++++++++++++++++++++++++---------- src/Ganeti/Objects.hs | 22 +++- src/Ganeti/Objects/Lens.hs | 2 + src/Ganeti/Query/Network.hs | 8 +- test/hs/Test/Ganeti/Network.hs | 100 +++++------------- test/hs/Test/Ganeti/Objects.hs | 21 ++-- 7 files changed, 254 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..0196b7d 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,197 @@ 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 + +addressPoolIso :: Iso' AddressPool BA.BitArray +addressPoolIso = iso apReservations AddressPool + +poolLens :: PoolPart -> Lens' Network (Maybe AddressPool) +poolLens PoolInstances = networkReservationsL +poolLens PoolExt = networkExtReservationsL + +poolArrayLens :: PoolPart -> Lens' Network (Maybe BA.BitArray) +poolArrayLens part = poolLens part . mapping addressPoolIso + +netIpv4NumHosts :: Network -> Integer +netIpv4NumHosts = ipv4NumHosts . ip4netMask . networkNetwork + +-- | Creates a new bit array pool of the appropriate size +newPoolArray :: (MonadError e m, Error e) => Network -> m BA.BitArray +newPoolArray 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) + +-- | Creates a new bit array pool of the appropriate size +newPool :: (MonadError e m, Error e) => Network -> m AddressPool +newPool = liftM AddressPool . newPoolArray + +-- | A helper function that creates a bit array pool, of it's missing. +orNewPool :: (MonadError e m, Error e) + => Network -> Maybe AddressPool -> m AddressPool +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) + . mapMOf2 addressPoolIso (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 . poolArrayLens + +readPoolE :: (MonadError e m, Error e) + => PoolPart -> Network -> m BA.BitArray +readPoolE part net = + liftM apReservations $ orNewPool net ((view . poolLens) part net) + +readAllE :: (MonadError e m, Error e) + => Network -> m BA.BitArray +readAllE net = do + let toRes = liftM apReservations . orNewPool net + res <- toRes $ networkReservations net + ext <- toRes $ 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..ebb8af8 100644 --- a/src/Ganeti/Objects.hs +++ b/src/Ganeti/Objects.hs @@ -87,6 +87,7 @@ module Ganeti.Objects , DictObject(..) -- re-exported from THH , TagSet -- re-exported from THH , Network(..) + , AddressPool(..) , Ip4Address() , mkIp4Address , Ip4Network() @@ -120,6 +121,7 @@ import qualified AutoConf import qualified Ganeti.Constants as C import qualified Ganeti.ConstantUtils as ConstantUtils import Ganeti.JSON +import Ganeti.Objects.BitArray (BitArray) import Ganeti.Types import Ganeti.THH import Ganeti.THH.Field @@ -237,10 +239,26 @@ instance JSON Ip4Network where _ -> fail $ "Can't parse IPv4 network from string " ++ fromJSString s readJSON v = fail $ "Invalid JSON value " ++ show v ++ " for an IPv4 network" +-- ** Address pools + +-- | Currently address pools just wrap a reservation 'BitArray'. +-- +-- In future, 'Network' might be extended to include several address pools +-- and address pools might include their own ranges of addresses. +newtype AddressPool = AddressPool { apReservations :: BitArray } + deriving (Eq, Ord, Show) + +instance JSON AddressPool where + showJSON = showJSON . apReservations + readJSON = liftM AddressPool . readJSON + -- ** Ganeti \"network\" config object. -- 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 +271,9 @@ $(buildObject "Network" "network" $ , optionalField $ simpleField "gateway6" [t| String |] , optionalField $ - simpleField "reservations" [t| String |] + simpleField "reservations" [t| AddressPool |] , optionalField $ - simpleField "ext_reservations" [t| String |] + simpleField "ext_reservations" [t| AddressPool |] ] ++ uuidFields ++ timeStampFields diff --git a/src/Ganeti/Objects/Lens.hs b/src/Ganeti/Objects/Lens.hs index 56aa5a7..21ce41f 100644 --- a/src/Ganeti/Objects/Lens.hs +++ b/src/Ganeti/Objects/Lens.hs @@ -49,6 +49,8 @@ class SerialNoObject a => SerialNoObjectL a where class TagsObject a => TagsObjectL a where tagsL :: Lens' a (Set.Set String) +$(makeCustomLenses ''AddressPool) + $(makeCustomLenses ''Network) instance SerialNoObjectL Network where 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 399eac2..4c5da26 100644 --- a/test/hs/Test/Ganeti/Objects.hs +++ b/test/hs/Test/Ganeti/Objects.hs @@ -62,6 +62,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 @@ -258,6 +259,9 @@ instance Arbitrary IAllocatorParams where $(genArbitrary ''Cluster) +instance Arbitrary AddressPool where + arbitrary = AddressPool . BA.fromList <$> arbitrary + instance Arbitrary Network where arbitrary = genValidNetwork @@ -284,12 +288,13 @@ 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 AddressPool +genBitString len = + (AddressPool . 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 AddressPool genBitStringMaxLen maxLen = choose (0, maxLen) >>= genBitString -- | Generator for config data with an empty cluster (no instances), @@ -394,6 +399,10 @@ prop_Node_serialisation = testSerialisation prop_Inst_serialisation :: Instance -> Property prop_Inst_serialisation = testSerialisation +-- | Check that address pool serialisation is idempotent. +prop_AddressPool_serialisation :: AddressPool -> Property +prop_AddressPool_serialisation = testSerialisation + -- | Check that network serialisation is idempotent. prop_Network_serialisation :: Network -> Property prop_Network_serialisation = testSerialisation @@ -449,10 +458,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. @@ -648,6 +654,7 @@ testSuite "Objects" , 'prop_Disk_serialisation , 'prop_Disk_array_serialisation , 'prop_Inst_serialisation + , 'prop_AddressPool_serialisation , 'prop_Network_serialisation , 'prop_Node_serialisation , 'prop_Config_serialisation -- 2.0.0.526.g5318336
