import Ganeti.HTools.Types
--- | Class for types which support show help and show version
+-- | Class for types which support show help and show version.
class CLIOptions a where
+ -- | Denotes whether the show help option has been passed.
showHelp :: a -> Bool
+ -- | Denotes whether the show version option has been passed.
showVersion :: a -> Bool
--- | Class for types which support the -i/-n/-m options
+-- | Class for types which support the -i\/-n\/-m options.
class EToolOptions a where
+ -- | Returns the node file name.
nodeFile :: a -> FilePath
+ -- | Tells whether the node file has been passed as an option.
nodeSet :: a -> Bool
+ -- | Returns the instance file name.
instFile :: a -> FilePath
+ -- | Tells whether the instance file has been passed as an option.
instSet :: a -> Bool
+ -- | Rapi target, if one has been passed.
masterName :: a -> String
+ -- | Whether to be less verbose.
silent :: a -> Bool
-- | Command line parser, using the 'options' structure.
where header = printf "%s %s\nUsage: %s [OPTION...]"
progname Version.version progname
--- | Parse the environment and return the node/instance names.
--- This also hardcodes here the default node/instance file names.
+-- | Parse the environment and return the node\/instance names.
+--
+-- This also hardcodes here the default node\/instance file names.
parseEnv :: () -> IO (String, String)
parseEnv () = do
a <- getEnvDefault "HTOOLS_NODES" "nodes"
b <- getEnvDefault "HTOOLS_INSTANCES" "instances"
return (a, b)
--- | A shell script template for autogenerated scripts
+-- | A shell script template for autogenerated scripts.
shTemplate :: String
shTemplate =
printf "#!/bin/sh\n\n\
\ fi\n\
\}\n\n"
--- | External tool data loader from a variety of sources
+-- | External tool data loader from a variety of sources.
loadExternalData :: (EToolOptions a) =>
a
-> IO (Node.List, Instance.List, String)
import Ganeti.HTools.Types
import Ganeti.HTools.Utils
--- | A separate name for the cluster score type
+-- * Types
+
+-- | A separate name for the cluster score type.
type Score = Double
-- | The description of an instance placement.
type Placement = (Idx, Ndx, Ndx, Score)
-{- | A cluster solution described as the solution delta and the list
-of placements.
-
--}
+-- | A cluster solution described as the solution delta and the list
+-- of placements.
data Solution = Solution Int [Placement]
deriving (Eq, Ord, Show)
--- | Returns the delta of a solution or -1 for Nothing
-solutionDelta :: Maybe Solution -> Int
-solutionDelta sol = case sol of
- Just (Solution d _) -> d
- _ -> -1
-
-- | A removal set.
data Removal = Removal Node.List [Instance.Instance]
data Table = Table Node.List Instance.List Score [Placement]
deriving (Show)
--- General functions
+-- * Utility functions
+
+-- | Returns the delta of a solution or -1 for Nothing.
+solutionDelta :: Maybe Solution -> Int
+solutionDelta sol = case sol of
+ Just (Solution d _) -> d
+ _ -> -1
-- | Cap the removal list if needed.
capRemovals :: [a] -> Int -> [a]
verifyN1 :: [Node.Node] -> [Node.Node]
verifyN1 nl = filter Node.failN1 nl
-{-| Add an instance and return the new node and instance maps. -}
+{-| Computes the pair of bad nodes and instances.
+
+The bad node list is computed via a simple 'verifyN1' check, and the
+bad instance list is the list of primary and secondary instances of
+those nodes.
+
+-}
+computeBadItems :: Node.List -> Instance.List ->
+ ([Node.Node], [Instance.Instance])
+computeBadItems nl il =
+ let bad_nodes = verifyN1 $ filter (not . Node.offline) $ Container.elems nl
+ bad_instances = map (\idx -> Container.find idx il) $
+ sort $ nub $ concat $
+ map (\ n -> (Node.slist n) ++ (Node.plist n)) bad_nodes
+ in
+ (bad_nodes, bad_instances)
+
+-- | Compute the total free disk and memory in the cluster.
+totalResources :: Container.Container Node.Node -> (Int, Int)
+totalResources nl =
+ foldl'
+ (\ (mem, dsk) node -> (mem + (Node.f_mem node),
+ dsk + (Node.f_dsk node)))
+ (0, 0) (Container.elems nl)
+
+-- | Compute the mem and disk covariance.
+compDetailedCV :: Node.List -> (Double, Double, Double, Double, Double)
+compDetailedCV nl =
+ let
+ all_nodes = Container.elems nl
+ (offline, nodes) = partition Node.offline all_nodes
+ mem_l = map Node.p_mem nodes
+ dsk_l = map Node.p_dsk nodes
+ mem_cv = varianceCoeff mem_l
+ dsk_cv = varianceCoeff dsk_l
+ n1_l = length $ filter Node.failN1 nodes
+ n1_score = (fromIntegral n1_l) / (fromIntegral $ length nodes)
+ res_l = map Node.p_rem nodes
+ res_cv = varianceCoeff res_l
+ offline_inst = sum . map (\n -> (length . Node.plist $ n) +
+ (length . Node.slist $ n)) $ offline
+ online_inst = sum . map (\n -> (length . Node.plist $ n) +
+ (length . Node.slist $ n)) $ nodes
+ off_score = (fromIntegral offline_inst) /
+ (fromIntegral $ online_inst + offline_inst)
+ in (mem_cv, dsk_cv, n1_score, res_cv, off_score)
+
+-- | Compute the /total/ variance.
+compCV :: Node.List -> Double
+compCV nl =
+ let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
+ in mem_cv + dsk_cv + n1_score + res_cv + off_score
+
+-- * hn1 functions
+
+-- | Add an instance and return the new node and instance maps.
addInstance :: Node.List -> Instance.Instance ->
Node.Node -> Node.Node -> Maybe Node.List
addInstance nl idata pri sec =
removeInstances :: Node.List -> [Instance.Instance] -> Node.List
removeInstances = foldl' removeInstance
--- | Compute the total free disk and memory in the cluster.
-totalResources :: Container.Container Node.Node -> (Int, Int)
-totalResources nl =
- foldl'
- (\ (mem, dsk) node -> (mem + (Node.f_mem node),
- dsk + (Node.f_dsk node)))
- (0, 0) (Container.elems nl)
-{- | Compute a new version of a cluster given a solution.
+{-| Compute a new version of a cluster given a solution.
This is not used for computing the solutions, but for applying a
(known-good) solution to the original cluster for final display.
) nc odxes
--- First phase functions
+-- ** First phase functions
-{- | Given a list 1,2,3..n build a list of pairs [(1, [2..n]), (2,
+{-| Given a list 1,2,3..n build a list of pairs [(1, [2..n]), (2,
[3..n]), ...]
-}
in
aux_fn count1 names1 []
-{- | Computes the pair of bad nodes and instances.
-
-The bad node list is computed via a simple 'verifyN1' check, and the
-bad instance list is the list of primary and secondary instances of
-those nodes.
-
--}
-computeBadItems :: Node.List -> Instance.List ->
- ([Node.Node], [Instance.Instance])
-computeBadItems nl il =
- let bad_nodes = verifyN1 $ filter (not . Node.offline) $ Container.elems nl
- bad_instances = map (\idx -> Container.find idx il) $
- sort $ nub $ concat $
- map (\ n -> (Node.slist n) ++ (Node.plist n)) bad_nodes
- in
- (bad_nodes, bad_instances)
-
-
-{- | Checks if removal of instances results in N+1 pass.
+{-| Checks if removal of instances results in N+1 pass.
Note: the check removal cannot optimize by scanning only the affected
nodes, since the cluster is known to be not healthy; only the check
Just $ Removal nx victims
--- | Computes the removals list for a given depth
+-- | Computes the removals list for a given depth.
computeRemovals :: Node.List
-> [Instance.Instance]
-> Int
computeRemovals nl bad_instances depth =
map (checkRemoval nl) $ genNames depth bad_instances
--- Second phase functions
+-- ** Second phase functions
--- | Single-node relocation cost
+-- | Single-node relocation cost.
nodeDelta :: Ndx -> Ndx -> Ndx -> Int
nodeDelta i p s =
if i == p || i == s then
else
1
-{-| Compute best solution.
-
- This function compares two solutions, choosing the minimum valid
- solution.
--}
+-- | Compute best solution.
+--
+-- This function compares two solutions, choosing the minimum valid
+-- solution.
compareSolutions :: Maybe Solution -> Maybe Solution -> Maybe Solution
compareSolutions a b = case (a, b) of
(Nothing, x) -> x
(x, Nothing) -> x
(x, y) -> min x y
--- | Compute best table. Note that the ordering of the arguments is important.
-compareTables :: Table -> Table -> Table
-compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
- if a_cv > b_cv then b else a
-
-- | Check if a given delta is worse then an existing solution.
tooHighDelta :: Maybe Solution -> Int -> Int -> Bool
tooHighDelta sol new_delta max_delta =
) accu_p nodes
) prev_sol nodes
--- | Apply a move
+{-| Auxiliary function for solution computation.
+
+We write this in an explicit recursive fashion in order to control
+early-abort in case we have met the min delta. We can't use foldr
+instead of explicit recursion since we need the accumulator for the
+abort decision.
+
+-}
+advanceSolution :: [Maybe Removal] -- ^ The removal to process
+ -> Int -- ^ Minimum delta parameter
+ -> Int -- ^ Maximum delta parameter
+ -> Maybe Solution -- ^ Current best solution
+ -> Maybe Solution -- ^ New best solution
+advanceSolution [] _ _ sol = sol
+advanceSolution (Nothing:xs) m n sol = advanceSolution xs m n sol
+advanceSolution ((Just (Removal nx removed)):xs) min_d max_d prev_sol =
+ let new_sol = checkPlacement nx removed [] 0 prev_sol max_d
+ new_delta = solutionDelta $! new_sol
+ in
+ if new_delta >= 0 && new_delta <= min_d then
+ new_sol
+ else
+ advanceSolution xs min_d max_d new_sol
+
+-- | Computes the placement solution.
+solutionFromRemovals :: [Maybe Removal] -- ^ The list of (possible) removals
+ -> Int -- ^ Minimum delta parameter
+ -> Int -- ^ Maximum delta parameter
+ -> Maybe Solution -- ^ The best solution found
+solutionFromRemovals removals min_delta max_delta =
+ advanceSolution removals min_delta max_delta Nothing
+
+{-| Computes the solution at the given depth.
+
+This is a wrapper over both computeRemovals and
+solutionFromRemovals. In case we have no solution, we return Nothing.
+
+-}
+computeSolution :: Node.List -- ^ The original node data
+ -> [Instance.Instance] -- ^ The list of /bad/ instances
+ -> Int -- ^ The /depth/ of removals
+ -> Int -- ^ Maximum number of removals to process
+ -> Int -- ^ Minimum delta parameter
+ -> Int -- ^ Maximum delta parameter
+ -> Maybe Solution -- ^ The best solution found (or Nothing)
+computeSolution nl bad_instances depth max_removals min_delta max_delta =
+ let
+ removals = computeRemovals nl bad_instances depth
+ removals' = capRemovals removals max_removals
+ in
+ solutionFromRemovals removals' min_delta max_delta
+
+-- * hbal functions
+
+-- | Compute best table. Note that the ordering of the arguments is important.
+compareTables :: Table -> Table -> Table
+compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
+ if a_cv > b_cv then b else a
+
+-- | Applies an instance move to a given node list and instance.
applyMove :: Node.List -> Instance.Instance
-> IMove -> (Maybe Node.List, Instance.Instance, Ndx, Ndx)
-- Failover (f)
Container.addTwo old_sdx new_p old_pdx int_p nl
in (new_nl, Instance.setBoth inst old_sdx new_sdx, old_sdx, new_sdx)
+-- | Tries to allocate an instance on one given node.
allocateOnSingle :: Node.List -> Instance.Instance -> Node.Node
-> (Maybe Node.List, Instance.Instance)
allocateOnSingle nl inst p =
return $ Container.add new_pdx new_p nl
in (new_nl, Instance.setBoth inst new_pdx Node.noSecondary)
+-- | Tries to allocate an instance on a given pair of nodes.
allocateOnPair :: Node.List -> Instance.Instance -> Node.Node -> Node.Node
-> (Maybe Node.List, Instance.Instance)
allocateOnPair nl inst tgt_p tgt_s =
return $ Container.addTwo new_pdx new_p new_sdx new_s nl
in (new_nl, Instance.setBoth inst new_pdx new_sdx)
+-- | Tries to perform an instance move and returns the best table
+-- between the original one and the new one.
checkSingleStep :: Table -- ^ The original table
-> Instance.Instance -- ^ The instance to move
-> Table -- ^ The current best table
else
best_tbl
-{- | Auxiliary function for solution computation.
-
-We write this in an explicit recursive fashion in order to control
-early-abort in case we have met the min delta. We can't use foldr
-instead of explicit recursion since we need the accumulator for the
-abort decision.
-
--}
-advanceSolution :: [Maybe Removal] -- ^ The removal to process
- -> Int -- ^ Minimum delta parameter
- -> Int -- ^ Maximum delta parameter
- -> Maybe Solution -- ^ Current best solution
- -> Maybe Solution -- ^ New best solution
-advanceSolution [] _ _ sol = sol
-advanceSolution (Nothing:xs) m n sol = advanceSolution xs m n sol
-advanceSolution ((Just (Removal nx removed)):xs) min_d max_d prev_sol =
- let new_sol = checkPlacement nx removed [] 0 prev_sol max_d
- new_delta = solutionDelta $! new_sol
- in
- if new_delta >= 0 && new_delta <= min_d then
- new_sol
- else
- advanceSolution xs min_d max_d new_sol
-
--- | Computes the placement solution.
-solutionFromRemovals :: [Maybe Removal] -- ^ The list of (possible) removals
- -> Int -- ^ Minimum delta parameter
- -> Int -- ^ Maximum delta parameter
- -> Maybe Solution -- ^ The best solution found
-solutionFromRemovals removals min_delta max_delta =
- advanceSolution removals min_delta max_delta Nothing
-
-{- | Computes the solution at the given depth.
-
-This is a wrapper over both computeRemovals and
-solutionFromRemovals. In case we have no solution, we return Nothing.
--}
-computeSolution :: Node.List -- ^ The original node data
- -> [Instance.Instance] -- ^ The list of /bad/ instances
- -> Int -- ^ The /depth/ of removals
- -> Int -- ^ Maximum number of removals to process
- -> Int -- ^ Minimum delta parameter
- -> Int -- ^ Maximum delta parameter
- -> Maybe Solution -- ^ The best solution found (or Nothing)
-computeSolution nl bad_instances depth max_removals min_delta max_delta =
- let
- removals = computeRemovals nl bad_instances depth
- removals' = capRemovals removals max_removals
- in
- solutionFromRemovals removals' min_delta max_delta
-
--- Solution display functions (pure)
+-- * Formatting functions
-- | Given the original and final nodes, computes the relocation description.
computeMoves :: String -- ^ The instance name
printf "migrate -f %s" i,
printf "replace-disks -n %s %s" d i])
-{-| Converts a placement to string format -}
-printSolutionLine :: Node.List
- -> Instance.List
- -> Int
- -> Int
- -> Placement
- -> Int
+-- | Converts a placement to string format.
+printSolutionLine :: Node.List -- ^ The node list
+ -> Instance.List -- ^ The instance list
+ -> Int -- ^ Maximum node name length
+ -> Int -- ^ Maximum instance name length
+ -> Placement -- ^ The current placement
+ -> Int -- ^ The index of the placement in
+ -- the solution
-> (String, [String])
printSolutionLine nl il nmlen imlen plc pos =
let
pmlen nstr c moves,
cmds)
+-- | Given a list of commands, prefix them with @gnt-instance@ and
+-- also beautify the display a little.
formatCmds :: [[String]] -> String
formatCmds cmd_strs =
unlines $
(map ("gnt-instance " ++) b)) $
zip [1..] cmd_strs
-{-| Converts a solution to string format -}
+-- | Converts a solution to string format.
printSolution :: Node.List
-> Instance.List
-> [Placement]
"pri" "sec" "p_fmem" "p_fdsk"
in unlines $ (header:map helper snl)
--- | Compute the mem and disk covariance.
-compDetailedCV :: Node.List -> (Double, Double, Double, Double, Double)
-compDetailedCV nl =
- let
- all_nodes = Container.elems nl
- (offline, nodes) = partition Node.offline all_nodes
- mem_l = map Node.p_mem nodes
- dsk_l = map Node.p_dsk nodes
- mem_cv = varianceCoeff mem_l
- dsk_cv = varianceCoeff dsk_l
- n1_l = length $ filter Node.failN1 nodes
- n1_score = (fromIntegral n1_l) / (fromIntegral $ length nodes)
- res_l = map Node.p_rem nodes
- res_cv = varianceCoeff res_l
- offline_inst = sum . map (\n -> (length . Node.plist $ n) +
- (length . Node.slist $ n)) $ offline
- online_inst = sum . map (\n -> (length . Node.plist $ n) +
- (length . Node.slist $ n)) $ nodes
- off_score = (fromIntegral offline_inst) /
- (fromIntegral $ online_inst + offline_inst)
- in (mem_cv, dsk_cv, n1_score, res_cv, off_score)
-
--- | Compute the 'total' variance.
-compCV :: Node.List -> Double
-compCV nl =
- let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
- in mem_cv + dsk_cv + n1_score + res_cv + off_score
-
+-- | Shows statistics for a given node list.
printStats :: Node.List -> String
printStats nl =
let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
addTwo :: Key -> a -> Key -> a -> Container a -> Container a
addTwo k1 v1 k2 v2 c = add k1 v1 $ add k2 v2 c
--- | Compute the name of an element in a container
+-- | Compute the name of an element in a container.
nameOf :: (T.Element a) => Container a -> Key -> String
nameOf c k = T.nameOf $ find k c
--- | Compute the maximum name length in an Element Container
+-- | Compute the maximum name length in an Element Container.
maxNameLen :: (T.Element a) => Container a -> Int
maxNameLen = maximum . map (length . T.nameOf) . elems
--- | Find an element by name in a Container; this is a very slow function
+-- | Find an element by name in a Container; this is a very slow function.
findByName :: (T.Element a, Monad m) =>
Container a -> String -> m Key
findByName c n =
) where
import Data.Either ()
---import Data.Maybe
import Control.Monad
import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
makeObj, encodeStrict, decodeStrict,
fromJSObject, toJSString)
---import Text.Printf (printf)
import qualified Ganeti.HTools.Container as Container
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Instance as Instance
import Ganeti.HTools.Utils
import Ganeti.HTools.Types
+-- | The request type.
data RqType
- = Allocate Instance.Instance Int
- | Relocate Idx Int [Ndx]
+ = Allocate Instance.Instance Int -- ^ A new instance allocation
+ | Relocate Idx Int [Ndx] -- ^ Move an instance to a new
+ -- secondary node
deriving (Show)
+-- | A complete request, as received from Ganeti.
data Request = Request RqType Node.List Instance.List String
deriving (Show)
+-- | Parse the basic specifications of an instance.
+--
+-- Instances in the cluster instance list and the instance in an
+-- 'Allocate' request share some common properties, which are read by
+-- this function.
parseBaseInstance :: String
-> JSObject JSValue
-> Result (String, Instance.Instance)
let running = "running"
return $ (n, Instance.create n mem disk running 0 0)
-parseInstance :: NameAssoc
- -> String
- -> JSObject JSValue
+-- | Parses an instance as found in the cluster instance list.
+parseInstance :: NameAssoc -- ^ The node name-to-index association list
+ -> String -- ^ The name of the instance
+ -> JSObject JSValue -- ^ The JSON object
-> Result (String, Instance.Instance)
parseInstance ktn n a = do
base <- parseBaseInstance n a
else (readEitherString $ head snodes) >>= lookupNode ktn n)
return (n, Instance.setBoth (snd base) pidx sidx)
-parseNode :: String -> JSObject JSValue -> Result (String, Node.Node)
+-- | Parses a node as found in the cluster node list.
+parseNode :: String -- ^ The node's name
+ -> JSObject JSValue -- ^ The JSON object
+ -> Result (String, Node.Node)
parseNode n a = do
let name = n
offline <- fromObj "offline" a
dtotal dfree (offline || drained))
return (name, node)
-parseData :: String -> Result Request
+-- | Top-level parser.
+parseData :: String -- ^ The JSON message as received from Ganeti
+ -> Result Request -- ^ A (possible valid) request
parseData body = do
decoded <- fromJResult $ decodeStrict body
let obj = decoded
other -> fail $ ("Invalid request type '" ++ other ++ "'")
return $ Request rqtype map_n map_i csf
-formatResponse :: Bool -> String -> [String] -> String
+-- | Formats the response into a valid IAllocator response message.
+formatResponse :: Bool -- ^ Whether the request was successful
+ -> String -- ^ Information text
+ -> [String] -- ^ The list of chosen nodes
+ -> String -- ^ The JSON-formatted message
formatResponse success info nodes =
let
e_success = ("success", JSBool success)
import qualified Ganeti.HTools.Types as T
import qualified Ganeti.HTools.Container as Container
-data Instance = Instance { name :: String -- ^ the instance name
- , mem :: Int -- ^ memory of the instance
- , dsk :: Int -- ^ disk size of instance
- , running :: Bool -- ^ whether the instance
+-- * Type declarations
+
+-- | The instance type
+data Instance = Instance { name :: String -- ^ The instance name
+ , mem :: Int -- ^ Memory of the instance
+ , dsk :: Int -- ^ Disk size of instance
+ , running :: Bool -- ^ Whether the instance
-- is running
- , run_st :: String -- ^ original (text) run status
- , pnode :: T.Ndx -- ^ original primary node
- , snode :: T.Ndx -- ^ original secondary node
- , idx :: T.Idx -- ^ internal index for
+ , run_st :: String -- ^ Original (text) run status
+ , pnode :: T.Ndx -- ^ Original primary node
+ , snode :: T.Ndx -- ^ Original secondary node
+ , idx :: T.Idx -- ^ Internal index for
-- book-keeping
} deriving (Show)
setName = setName
setIdx = setIdx
--- | A simple name for the int, instance association list
+-- | A simple name for the int, instance association list.
type AssocList = [(T.Idx, Instance)]
--- | A simple name for an instance map
+-- | A simple name for an instance map.
type List = Container.Container Instance
+-- * Initialization
+
+-- | Create an instance.
+--
+-- Some parameters are not initialized by function, and must be set
+-- later (via 'setIdx' for example).
create :: String -> Int -> Int -> String -> T.Ndx -> T.Ndx -> Instance
create name_init mem_init dsk_init run_init pn sn =
Instance {
idx = -1
}
+-- | Changes the index.
+--
+-- This is used only during the building of the data structures.
+setIdx :: Instance -- ^ the original instance
+ -> T.Idx -- ^ new index
+ -> Instance -- ^ the modified instance
+setIdx t i = t { idx = i }
+
+-- | Changes the name.
+--
+-- This is used only during the building of the data structures.
+setName :: Instance -- ^ The original instance
+ -> String -- ^ New name
+ -> Instance
+setName t s = t { name = s }
+
+-- * Update functions
+
-- | Changes the primary node of the instance.
setPri :: Instance -- ^ the original instance
-> T.Ndx -- ^ the new primary node
-> T.Ndx -- ^ new secondary node index
-> Instance -- ^ the modified instance
setBoth t p s = t { pnode = p, snode = s }
-
--- | Changes the index.
--- This is used only during the building of the data structures.
-setIdx :: Instance -- ^ the original instance
- -> T.Idx -- ^ new index
- -> Instance -- ^ the modified instance
-setIdx t i = t { idx = i }
-
--- | Changes the name
--- This is used only during the building of the data structures.
-setName t s = t { name = s }
import Ganeti.HTools.Types
--- | Lookups a node into an assoc list
+-- | Lookups a node into an assoc list.
lookupNode :: (Monad m) => [(String, Ndx)] -> String -> String -> m Ndx
lookupNode ktn inst node =
case lookup node ktn of
Nothing -> fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst
Just idx -> return idx
--- | Lookups an instance into an assoc list
+-- | Lookups an instance into an assoc list.
lookupInstance :: (Monad m) => [(String, Idx)] -> String -> m Idx
lookupInstance kti inst =
case lookup inst kti of
Nothing -> fail $ "Unknown instance '" ++ inst ++ "'"
Just idx -> return idx
--- | Given a list of elements (and their names), assign indices to them
+-- | Given a list of elements (and their names), assign indices to them.
assignIndices :: (Element a) =>
[(String, a)]
-> (NameAssoc, [(Int, a)])
unzip . map (\ (idx, (k, v)) -> ((k, idx), (idx, setIdx v idx)))
. zip [0..]
--- | For each instance, add its index to its primary and secondary nodes
+-- | For each instance, add its index to its primary and secondary nodes.
fixNodes :: [(Ndx, Node.Node)]
-> [(Idx, Instance.Instance)]
-> [(Ndx, Node.Node)]
) nl il
-- | Compute the longest common suffix of a list of strings that
--- | starts with a dot
+-- | starts with a dot.
longestDomain :: [String] -> String
longestDomain [] = ""
longestDomain (x:xs) =
else accu)
"" $ filter (isPrefixOf ".") (tails x)
--- | Remove tail suffix from a string
+-- | Remove tail suffix from a string.
stripSuffix :: Int -> String -> String
stripSuffix sflen name = take ((length name) - sflen) name
-{-| Initializer function that loads the data from a node and list file
- and massages it into the correct format. -}
+-- | Initializer function that loads the data from a node and instance
+-- list and massages it into the correct format.
mergeData :: (Node.AssocList,
Instance.AssocList) -- ^ Data from either Text.loadData
-- or Rapi.loadData
sil = Container.map (\i -> setName i (stripSuffix csl $ nameOf i)) il3
return (snl, sil, common_suffix)
--- | Check cluster data for consistency
+-- | Checks the cluster data for consistency.
checkData :: Node.List -> Instance.List
-> ([String], Node.List)
checkData nl il =
, setOffline
, setXmem
, setFmem
+ , setPri
+ , setSec
-- * Instance (re)location
, removePri
, removeSec
, addPri
, addSec
- , setPri
- , setSec
-- * Formatting
, list
-- * Misc stuff
import qualified Ganeti.HTools.Types as T
-data Node = Node { name :: String -- ^ the node name
- , t_mem :: Double -- ^ total memory (MiB)
- , n_mem :: Int -- ^ node memory (MiB)
- , f_mem :: Int -- ^ free memory (MiB)
- , x_mem :: Int -- ^ unaccounted memory (MiB)
- , t_dsk :: Double -- ^ total disk space (MiB)
- , f_dsk :: Int -- ^ free disk space (MiB)
- , plist :: [T.Idx]-- ^ list of primary instance indices
- , slist :: [T.Idx]-- ^ list of secondary instance indices
- , idx :: T.Ndx -- ^ internal index for book-keeping
- , peers :: PeerMap.PeerMap -- ^ pnode to instance mapping
- , failN1:: Bool -- ^ whether the node has failed n1
- , r_mem :: Int -- ^ maximum memory needed for
+-- * Type declarations
+
+-- | The node type.
+data Node = Node { name :: String -- ^ The node name
+ , t_mem :: Double -- ^ Total memory (MiB)
+ , n_mem :: Int -- ^ Node memory (MiB)
+ , f_mem :: Int -- ^ Free memory (MiB)
+ , x_mem :: Int -- ^ Unaccounted memory (MiB)
+ , t_dsk :: Double -- ^ Total disk space (MiB)
+ , f_dsk :: Int -- ^ Free disk space (MiB)
+ , plist :: [T.Idx]-- ^ List of primary instance indices
+ , slist :: [T.Idx]-- ^ List of secondary instance indices
+ , idx :: T.Ndx -- ^ Internal index for book-keeping
+ , peers :: PeerMap.PeerMap -- ^ Pnode to instance mapping
+ , failN1:: Bool -- ^ Whether the node has failed n1
+ , r_mem :: Int -- ^ Maximum memory needed for
-- failover by primaries of this node
- , p_mem :: Double -- ^ percent of free memory
- , p_dsk :: Double -- ^ percent of free disk
- , p_rem :: Double -- ^ percent of reserved memory
- , offline :: Bool -- ^ whether the node should not be used
+ , p_mem :: Double -- ^ Percent of free memory
+ , p_dsk :: Double -- ^ Percent of free disk
+ , p_rem :: Double -- ^ Percent of reserved memory
+ , offline :: Bool -- ^ Whether the node should not be used
-- for allocations and skipped from
-- score computations
} deriving (Show)
setName = setName
setIdx = setIdx
--- | A simple name for the int, node association list
+-- | A simple name for the int, node association list.
type AssocList = [(T.Ndx, Node)]
--- | A simple name for a node map
+-- | A simple name for a node map.
type List = Container.Container Node
--- | Constant node index for a non-moveable instance
+-- | Constant node index for a non-moveable instance.
noSecondary :: T.Ndx
noSecondary = -1
-{- | Create a new node.
-
-The index and the peers maps are empty, and will be need to be update
-later via the 'setIdx' and 'buildPeers' functions.
+-- * Initialization functions
--}
+-- | Create a new node.
+--
+-- The index and the peers maps are empty, and will be need to be
+-- update later via the 'setIdx' and 'buildPeers' functions.
create :: String -> Double -> Int -> Int -> Double -> Int -> Bool -> Node
create name_init mem_t_init mem_n_init mem_f_init
dsk_t_init dsk_f_init offline_init =
}
-- | Changes the index.
+--
-- This is used only during the building of the data structures.
setIdx :: Node -> T.Ndx -> Node
setIdx t i = t {idx = i}
--- | Changes the name
+-- | Changes the name.
+--
-- This is used only during the building of the data structures.
+setName :: Node -> String -> Node
setName t s = t {name = s}
--- | Sets the offline attribute
+-- | Sets the offline attribute.
setOffline :: Node -> Bool -> Node
setOffline t val = t { offline = val }
--- | Sets the unnaccounted memory
+-- | Sets the unnaccounted memory.
setXmem :: Node -> Int -> Node
setXmem t val = t { x_mem = val }
--- | Sets the free memory
-setFmem :: Node -> Int -> Node
-setFmem t new_mem =
- let new_n1 = computeFailN1 (r_mem t) new_mem (f_dsk t)
- new_mp = (fromIntegral new_mem) / (t_mem t)
- in
- t { f_mem = new_mem, failN1 = new_n1, p_mem = new_mp }
-
--- | Given the rmem, free memory and disk, computes the failn1 status.
-computeFailN1 :: Int -> Int -> Int -> Bool
-computeFailN1 new_rmem new_mem new_dsk =
- new_mem <= new_rmem || new_dsk <= 0
-
--- | Given the new free memory and disk, fail if any of them is below zero.
-failHealth :: Int -> Int -> Bool
-failHealth new_mem new_dsk = new_mem <= 0 || new_dsk <= 0
-
-- | Computes the maximum reserved memory for peers from a peer map.
computeMaxRes :: PeerMap.PeerMap -> PeerMap.Elem
computeMaxRes new_peers = PeerMap.maxElem new_peers
new_prem = (fromIntegral new_rmem) / (t_mem t)
in t {peers=pmap, failN1 = new_failN1, r_mem = new_rmem, p_rem = new_prem}
+-- | Assigns an instance to a node as primary without other updates.
+setPri :: Node -> T.Idx -> Node
+setPri t idx = t { plist = idx:(plist t) }
+
+-- | Assigns an instance to a node as secondary without other updates.
+setSec :: Node -> T.Idx -> Node
+setSec t idx = t { slist = idx:(slist t) }
+
+-- * Update functions
+
+-- | Sets the free memory.
+setFmem :: Node -> Int -> Node
+setFmem t new_mem =
+ let new_n1 = computeFailN1 (r_mem t) new_mem (f_dsk t)
+ new_mp = (fromIntegral new_mem) / (t_mem t)
+ in
+ t { f_mem = new_mem, failN1 = new_n1, p_mem = new_mp }
+
+-- | Given the rmem, free memory and disk, computes the failn1 status.
+computeFailN1 :: Int -> Int -> Int -> Bool
+computeFailN1 new_rmem new_mem new_dsk =
+ new_mem <= new_rmem || new_dsk <= 0
+
+-- | Given the new free memory and disk, fail if any of them is below zero.
+failHealth :: Int -> Int -> Bool
+failHealth new_mem new_dsk = new_mem <= 0 || new_dsk <= 0
+
-- | Removes a primary instance.
removePri :: Node -> Instance.Instance -> Node
removePri t inst =
r_mem = new_rmem, p_dsk = new_dp,
p_rem = new_prem}
--- | Add a primary instance to a node without other updates
-setPri :: Node -> T.Idx -> Node
-setPri t idx = t { plist = idx:(plist t) }
-
--- | Add a secondary instance to a node without other updates
-setSec :: Node -> T.Idx -> Node
-setSec t idx = t { slist = idx:(slist t) }
+-- * Display functions
-- | String converter for the node list functionality.
list :: Int -> Node -> String
type Elem = Int
type PeerMap = [(Key, Elem)]
--- | Create a new empty map
+-- * Initialization functions
+
+-- | Create a new empty map.
empty :: PeerMap
empty = []
--- | Our reverse-compare function
+-- | Our reverse-compare function.
pmCompare :: (Key, Elem) -> (Key, Elem) -> Ordering
pmCompare a b = (compare `on` snd) b a
--- | Add or update (via a custom function) an element
+-- | Add or update (via a custom function) an element.
addWith :: (Elem -> Elem -> Elem) -> Key -> Elem -> PeerMap -> PeerMap
addWith fn k v lst =
let r = lookup k lst
[] -> empty
(k, v):xs -> addWith fn k v $ accumArray fn xs
+-- * Basic operations
+
+-- | Returns either the value for a key or zero if not found
find :: Key -> PeerMap -> Elem
find k c = fromMaybe 0 $ lookup k c
+-- | Add an element to a peermap, overwriting the previous value
add :: Key -> Elem -> PeerMap -> PeerMap
add k v c = addWith (flip const) k v c
+-- | Remove an element from a peermap
remove :: Key -> PeerMap -> PeerMap
remove k c = case c of
[] -> []
(x@(x', _)):xs -> if k == x' then xs
else x:(remove k xs)
--- | Find the maximum element. Since this is a sorted list, we just
--- get the first one
+-- | Find the maximum element.
+--
+-- Since this is a sorted list, we just get the value at the head of
+-- the list, or zero for a null list
maxElem :: PeerMap -> Elem
maxElem c = if null c then 0 else snd . head $ c
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Instance as Instance
--- | Read an URL via curl and return the body if successful
+-- | Read an URL via curl and return the body if successful.
getUrl :: (Monad m) => String -> IO (m String)
getUrl url = do
(code, body) <- curlGetString url [CurlSSLVerifyPeer False,
_ -> fail $ printf "Curl error for '%s', error %s"
url (show code))
--- | Append the default port if not passed in
+-- | Append the default port if not passed in.
formatHost :: String -> String
formatHost master =
if elem ':' master then master
else "https://" ++ master ++ ":5080"
+-- | Parse a instance list in JSON format.
getInstances :: NameAssoc
-> String
-> Result [(String, Instance.Instance)]
ilist <- mapM (parseInstance ktn) arr
return ilist
+-- | Parse a node list in JSON format.
getNodes :: String -> Result [(String, Node.Node)]
getNodes body = do
arr <- loadJSArray body
nlist <- mapM parseNode arr
return nlist
+-- | Construct an instance from a JSON object.
parseInstance :: [(String, Ndx)]
-> JSObject JSValue
-> Result (String, Instance.Instance)
let inst = Instance.create name mem disk running pnode snode
return (name, inst)
+-- | Construct a node from a JSON object.
parseNode :: JSObject JSValue -> Result (String, Node.Node)
parseNode a = do
name <- fromObj "name" a
dtotal dfree (offline || drained))
return (name, node)
+-- | Builds the cluster data from an URL.
loadData :: String -- ^ Cluster or URL to use as source
-> IO (Result (Node.AssocList, Instance.AssocList))
loadData master = do -- IO monad
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Instance as Instance
--- | Safe 'read' function returning data encapsulated in a Result
+-- | Safe 'read' function returning data encapsulated in a Result.
tryRead :: (Monad m, Read a) => String -> String -> m a
tryRead name s =
let sols = readsPrec 0 s
++ s ++ "': '" ++ e ++ "'"
_ -> fail $ name ++ ": cannot parse string '" ++ s ++ "'"
--- | Load a node from a field list
+-- | Load a node from a field list.
loadNode :: (Monad m) => [String] -> m (String, Node.Node)
loadNode (name:tm:nm:fm:td:fd:fo:[]) = do
new_node <-
return (name, new_node)
loadNode s = fail $ "Invalid/incomplete node data: '" ++ (show s) ++ "'"
--- | Load an instance from a field list
+-- | Load an instance from a field list.
loadInst :: (Monad m) =>
[(String, Ndx)] -> [String] -> m (String, Instance.Instance)
loadInst ktn (name:mem:dsk:status:pnode:snode:[]) = do
return (name, newinst)
loadInst _ s = fail $ "Invalid/incomplete instance data: '" ++ (show s) ++ "'"
-{- | Convert newline and delimiter-separated text.
-
-This function converts a text in tabular format as generated by
-@gnt-instance list@ and @gnt-node list@ to a list of objects using a
-supplied conversion function.
-
--}
+-- | Convert newline and delimiter-separated text.
+--
+-- This function converts a text in tabular format as generated by
+-- @gnt-instance list@ and @gnt-node list@ to a list of objects using
+-- a supplied conversion function.
loadTabular :: (Monad m, Element a) =>
String -> ([String] -> m (String, a))
-> m ([(String, Int)], [(Int, a)])
kerows <- mapM convert_fn rows
return $ assignIndices kerows
+-- | Builds the cluster data from node\/instance files.
loadData :: String -- ^ Node data in string format
-> String -- ^ Instance data in string format
-> IO (Result (Node.AssocList, Instance.AssocList))
module Ganeti.HTools.Types
where
--- | The instance index type
+-- | The instance index type.
type Idx = Int
--- | The node index type
+-- | The node index type.
type Ndx = Int
--- | The type used to hold name-to-idx mappings
+-- | The type used to hold name-to-idx mappings.
type NameAssoc = [(String, Int)]
{-|
return = Ok
fail = Bad
--- | A generic class for items that have names and indices
+-- | A generic class for items that have updateable names and indices.
class Element a where
+ -- | Returns the name of the element
nameOf :: a -> String
+ -- | Returns the index of the element
idxOf :: a -> Int
+ -- | Updates the name of the element
setName :: a -> String -> a
+ -- | Updates the index of the element
setIdx :: a -> Int -> a
import Debug.Trace
+-- * Debug functions
+
-- | To be used only for debugging, breaks referential integrity.
debug :: Show a => a -> a
debug x = trace (show x) x
-
-fromJResult :: Monad m => J.Result a -> m a
-fromJResult (J.Error x) = fail x
-fromJResult (J.Ok x) = return x
+-- * Miscelaneous
-- | Comma-join a string list.
commaJoin :: [String] -> String
commaSplit :: String -> [String]
commaSplit = sepSplit ','
+-- * Mathematical functions
+
-- Simple and slow statistical functions, please replace with better versions
-- | Mean value of a list.
varianceCoeff :: Floating a => [a] -> a
varianceCoeff lst = (stdDev lst) / (fromIntegral $ length lst)
--- | Get an Ok result or print the error and exit
+-- | Get an Ok result or print the error and exit.
readData :: Result a -> IO a
readData nd =
(case nd of
exitWith $ ExitFailure 1
Ok x -> return x)
+-- * JSON-related functions
+
+-- | Converts a JSON Result into a monadic value.
+fromJResult :: Monad m => J.Result a -> m a
+fromJResult (J.Error x) = fail x
+fromJResult (J.Ok x) = return x
+
+-- | Tries to read a string from a JSON value.
+--
+-- In case the value was not a string, we fail the read (in the
+-- context of the current monad.
readEitherString :: (Monad m) => J.JSValue -> m String
readEitherString v =
case v of
J.JSString s -> return $ J.fromJSString s
_ -> fail "Wrong JSON type"
+-- | Converts a JSON message into an array of JSON objects.
loadJSArray :: (Monad m) => String -> m [J.JSObject J.JSValue]
loadJSArray s = fromJResult $ J.decodeStrict s
+-- | Reads a the value of a key in a JSON object.
fromObj :: (J.JSON a, Monad m) => String -> J.JSObject J.JSValue -> m a
fromObj k o =
case lookup k (J.fromJSObject o) of
Nothing -> fail $ printf "key '%s' not found in %s" k (show o)
Just val -> fromJResult $ J.readJSON val
+-- | Converts a JSON value into a JSON object.
asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
asJSObject (J.JSObject a) = return a
asJSObject _ = fail "not an object"
+-- | Coneverts a list of JSON values into a list of JSON objects.
asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
asObjectList = sequence . map asJSObject
version
) where
--- | The version of the tree
+-- | The version of the sources.
+version :: String
version = "(htools) version %ver%"
$(DOCS) : %.html : %
rst2html $< $@
-doc: $(DOCS)
- rm -rf $(HDDIR)
+doc: $(DOCS) Ganeti/HTools/Version.hs
+ rm -rf $(HDDIR)/*
mkdir -p $(HDDIR)/Ganeti/HTools
cp hscolour.css $(HDDIR)/Ganeti/HTools
for file in $(HSRCS); do \
projects / ganeti-local / commitdiff