Synnefo » snf-ganeti » ganeti-local

  , fillUpList

  , fillPairFromMaybe

  , pickPairUnique

-- | Order a list of pairs in the order of the given list and fill up

-- the list for elements that don't have a matching pair

fillUpList :: ([(a, b)] -> a -> (a, b)) -> [a] -> [(a, b)] -> [(a, b)]

fillUpList fill_fn inputs pairs =

  map (fill_fn pairs) inputs

-- | Fill up a pair with fillup element if no matching pair is present

fillPairFromMaybe :: (a -> (a, b)) -> (a -> [(a, b)] -> Maybe (a, b))

                  -> [(a, b)] -> a -> (a, b)

fillPairFromMaybe fill_fn pick_fn pairs element = fromMaybe (fill_fn element)

    (pick_fn element pairs)

-- | Check if the given element matches the given pair

isMatchingPair :: (Eq a) => a -> (a, b) -> Bool

isMatchingPair element (pair_element, _) = element == pair_element

-- | Pick a specific element's pair from the list

pickPairUnique :: (Eq a) => a -> [(a, b)] -> Maybe (a, b)

pickPairUnique element pairs =

  let res = filter (isMatchingPair element) pairs

  in case res of

    [x] -> Just x

    -- if we have more than one result, we should get suspcious

    _ -> Nothing

import Ganeti.Common

-- | Create an RPC result for a broken node

rpcResultNodeBroken :: Node -> (Node, Runtime)

rpcResultNodeBroken node = (node, Left (RpcResultError "Broken configuration"))

  let hvs = [getDefaultHypervisorSpec cfg]

      good_nodes = nodesWithValidConfig cfg nodes

      storage_units = getStorageUnitsOfNodes cfg good_nodes

  rpcres <- executeRpcCall good_nodes (RpcCallNodeInfo storage_units hvs)

  return $ fillUpList (fillPairFromMaybe rpcResultNodeBroken pickPairUnique)

      nodes rpcres

  [ simpleField "storage_units" [t| Map.Map String [StorageUnit] |]

    ( fromMaybe (error $ "Programmer error: missing parameter for node named "

          $ Map.lookup (nodeUuid n) (rpcCallNodeInfoStorageUnits call)

    , rpcCallNodeInfoHypervisors call

  ( getStorageUnitsOfNodes

  , nodesWithValidConfig

import Ganeti.Config

import Control.Monad

import Data.Maybe

import qualified Data.Map as M

getDefaultStorageKey :: ConfigData -> DiskTemplate -> Maybe StorageKey

getDefaultSpindleSU :: ConfigData -> (StorageType, Maybe StorageKey)

getClusterStorageUnitRaws :: ConfigData -> [StorageUnitRaw]

getClusterStorageUnitRaws cfg = foldSUs (maybe_units ++ [spindle_unit])

foldSUs :: [(StorageType, Maybe StorageKey)] -> [StorageUnitRaw]

  where ff (st, Just sk) acc = SURaw st sk : acc

-- | Gets the value of the 'exclusive storage' flag of the node

getExclusiveStorage :: ConfigData -> Node -> Maybe Bool

getExclusiveStorage cfg n = liftM ndpExclusiveStorage (getNodeNdParams cfg n)

-- | Determines whether a node's config contains an 'exclusive storage' flag

hasExclusiveStorageFlag :: ConfigData -> Node -> Bool

hasExclusiveStorageFlag cfg = isJust . getExclusiveStorage cfg

-- | Filter for nodes with a valid config

nodesWithValidConfig :: ConfigData -> [Node] -> [Node]

nodesWithValidConfig cfg = filter (hasExclusiveStorageFlag cfg)

-- | Get the storage units of the node

getStorageUnitsOfNode :: ConfigData -> Node -> [StorageUnit]

getStorageUnitsOfNode cfg n =

  let clusterSUs = getClusterStorageUnitRaws cfg

      es = fromJust (getExclusiveStorage cfg n)

  in  map (addParamsToStorageUnit es) clusterSUs

-- | Get the storage unit map for all nodes

getStorageUnitsOfNodes :: ConfigData -> [Node] -> M.Map String [StorageUnit]

getStorageUnitsOfNodes cfg ns =

  M.fromList (map (\n -> (nodeUuid n, getStorageUnitsOfNode cfg n)) ns)

  , storageTypeToRaw

  , StorageUnit(..)

  , StorageUnitRaw(..)

  , StorageKey

  , addParamsToStorageUnit

  , diskTemplateToStorageType

-- | Storage keys are identifiers for storage units. Their content varies

-- depending on the storage type, for example a storage key for LVM storage

-- is the volume group name.

type StorageKey = String

-- | Storage parameters

type SPExclusiveStorage = Bool

-- | Storage units without storage-type-specific parameters

data StorageUnitRaw = SURaw StorageType StorageKey

-- | Full storage unit with storage-type-specific parameters

data StorageUnit = SUFile StorageKey

                 | SULvmPv StorageKey SPExclusiveStorage

                 | SULvmVg StorageKey SPExclusiveStorage

                 | SUDiskless StorageKey

                 | SUBlock StorageKey

                 | SURados StorageKey

                 | SUExt StorageKey

                 deriving (Eq)

instance Show StorageUnit where

  show (SUFile key) = showSUSimple StorageFile key

  show (SULvmPv key es) = showSULvm StorageLvmPv key es

  show (SULvmVg key es) = showSULvm StorageLvmVg key es

  show (SUDiskless key) = showSUSimple StorageDiskless key

  show (SUBlock key) = showSUSimple StorageBlock key

  show (SURados key) = showSUSimple StorageRados key

  show (SUExt key) = showSUSimple StorageExt key

instance JSON StorageUnit where

  showJSON (SUFile key) = showJSON (StorageFile, key, []::[String])

  showJSON (SULvmPv key es) = showJSON (StorageLvmPv, key, [es])

  showJSON (SULvmVg key es) = showJSON (StorageLvmVg, key, [es])

  showJSON (SUDiskless key) = showJSON (StorageDiskless, key, []::[String])

  showJSON (SUBlock key) = showJSON (StorageBlock, key, []::[String])

  showJSON (SURados key) = showJSON (StorageRados, key, []::[String])

  showJSON (SUExt key) = showJSON (StorageExt, key, []::[String])

-- FIXME: add readJSON implementation

  readJSON = fail "Not implemented"

-- | Composes a string representation of storage types without

-- storage parameters

showSUSimple :: StorageType -> StorageKey -> String

showSUSimple st sk = show (storageTypeToRaw st, sk, []::[String])

-- | Composes a string representation of the LVM storage types

showSULvm :: StorageType -> StorageKey -> SPExclusiveStorage -> String

showSULvm st sk es = show (storageTypeToRaw st, sk, [es])

-- | Mapping fo disk templates to storage type

-- FIXME: This is semantically the same as the constant

-- C.diskTemplatesStorageType, remove this when python constants

-- are generated from haskell constants

diskTemplateToStorageType :: DiskTemplate -> StorageType

diskTemplateToStorageType DTExt = StorageExt

diskTemplateToStorageType DTFile = StorageFile

diskTemplateToStorageType DTSharedFile = StorageFile

diskTemplateToStorageType DTDrbd8 = StorageLvmVg

diskTemplateToStorageType DTPlain = StorageLvmVg

diskTemplateToStorageType DTRbd = StorageRados

diskTemplateToStorageType DTDiskless = StorageDiskless

diskTemplateToStorageType DTBlock = StorageBlock

-- | Equips a raw storage unit with its parameters

addParamsToStorageUnit :: SPExclusiveStorage -> StorageUnitRaw -> StorageUnit

addParamsToStorageUnit _ (SURaw StorageBlock key) = SUBlock key

addParamsToStorageUnit _ (SURaw StorageDiskless key) = SUDiskless key

addParamsToStorageUnit _ (SURaw StorageExt key) = SUExt key

addParamsToStorageUnit _ (SURaw StorageFile key) = SUFile key

addParamsToStorageUnit es (SURaw StorageLvmPv key) = SULvmPv key es

addParamsToStorageUnit es (SURaw StorageLvmVg key) = SULvmVg key es

addParamsToStorageUnit _ (SURaw StorageRados key) = SURados key

import Ganeti.Types

  arbitrary = Rpc.RpcCallNodeInfo <$> genStorageUnitMap <*> genHvSpecs

genStorageUnit :: Gen StorageUnit

genStorageUnit = do

  storage_type <- arbitrary

  storage_key <- genName

  storage_es <- arbitrary

  return $ addParamsToStorageUnit storage_es (SURaw storage_type storage_key)

genStorageUnits :: Gen [StorageUnit]

genStorageUnits = do

  num_storage_units <- choose (0, 5)

  vectorOf num_storage_units genStorageUnit

genStorageUnitMap :: Gen (Map.Map String [StorageUnit])

genStorageUnitMap = do

  num_nodes <- choose (0,5)

  node_uuids <- vectorOf num_nodes genName

  storage_units_list <- vectorOf num_nodes genStorageUnits

  return $ Map.fromList (zip node_uuids storage_units_list)