Synnefo » snf-ganeti » ganeti-local

	htools/Ganeti/Network.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

  ]

import Test.Ganeti.Query.Language (genJSValue)

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)

-- | Check that network serialisation is idempotent.

prop_Network_serialisation :: Network -> Property

prop_Network_serialisation = testSerialisation

  , 'prop_Network_serialisation

  , genJSValue

import Test.Ganeti.Network

  , testNetwork

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

  , Network(..)

-- * 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