1 {-| Implementation of cluster-wide logic.
3 This module holds all pure cluster-logic; I\/O related functionality
4 goes into the "Main" module for the individual binaries.
8 module Ganeti.HTools.Cluster
19 -- * Generic functions
21 -- * First phase functions
23 -- * Second phase functions
30 -- * Balacing functions
34 -- * Loading functions
40 import Data.Maybe (isNothing, fromJust)
41 import Text.Printf (printf)
45 import qualified Ganeti.HTools.Container as Container
46 import qualified Ganeti.HTools.Instance as Instance
47 import qualified Ganeti.HTools.Node as Node
48 import Ganeti.HTools.Utils
50 type NodeList = Container.Container Node.Node
51 type InstanceList = Container.Container Instance.Instance
52 -- | The type used to hold idx-to-name mappings
53 type NameList = [(Int, String)]
54 -- | A separate name for the cluster score type
57 -- | The description of an instance placement.
58 type Placement = (Int, Int, Int, Score)
60 {- | A cluster solution described as the solution delta and the list
64 data Solution = Solution Int [Placement]
65 deriving (Eq, Ord, Show)
67 -- | Returns the delta of a solution or -1 for Nothing
68 solutionDelta :: Maybe Solution -> Int
69 solutionDelta sol = case sol of
70 Just (Solution d _) -> d
74 data Removal = Removal NodeList [Instance.Instance]
76 -- | An instance move definition
77 data IMove = Failover -- ^ Failover the instance (f)
78 | ReplacePrimary Int -- ^ Replace primary (f, r:np, f)
79 | ReplaceSecondary Int -- ^ Replace secondary (r:ns)
80 | ReplaceAndFailover Int -- ^ Replace secondary, failover (r:np, f)
81 | FailoverAndReplace Int -- ^ Failover, replace secondary (f, r:ns)
84 -- | The complete state for the balancing solution
85 data Table = Table NodeList InstanceList Score [Placement]
90 -- | Cap the removal list if needed.
91 capRemovals :: [a] -> Int -> [a]
92 capRemovals removals max_removals =
93 if max_removals > 0 then
94 take max_removals removals
98 -- | Check if the given node list fails the N+1 check.
99 verifyN1Check :: [Node.Node] -> Bool
100 verifyN1Check nl = any Node.failN1 nl
102 -- | Verifies the N+1 status and return the affected nodes.
103 verifyN1 :: [Node.Node] -> [Node.Node]
104 verifyN1 nl = filter Node.failN1 nl
106 {-| Add an instance and return the new node and instance maps. -}
107 addInstance :: NodeList -> Instance.Instance ->
108 Node.Node -> Node.Node -> Maybe NodeList
109 addInstance nl idata pri sec =
110 let pdx = Node.idx pri
113 pnode <- Node.addPri pri idata
114 snode <- Node.addSec sec idata pdx
115 new_nl <- return $ Container.addTwo sdx snode
119 -- | Remove an instance and return the new node and instance maps.
120 removeInstance :: NodeList -> Instance.Instance -> NodeList
121 removeInstance nl idata =
122 let pnode = Instance.pnode idata
123 snode = Instance.snode idata
124 pn = Container.find pnode nl
125 sn = Container.find snode nl
126 new_nl = Container.addTwo
127 pnode (Node.removePri pn idata)
128 snode (Node.removeSec sn idata) nl in
131 -- | Remove an instance and return the new node map.
132 removeInstances :: NodeList -> [Instance.Instance] -> NodeList
133 removeInstances = foldl' removeInstance
135 -- | Compute the total free disk and memory in the cluster.
136 totalResources :: Container.Container Node.Node -> (Int, Int)
139 (\ (mem, dsk) node -> (mem + (Node.f_mem node),
140 dsk + (Node.f_dsk node)))
141 (0, 0) (Container.elems nl)
143 {- | Compute a new version of a cluster given a solution.
145 This is not used for computing the solutions, but for applying a
146 (known-good) solution to the original cluster for final display.
148 It first removes the relocated instances after which it places them on
152 applySolution :: NodeList -> InstanceList -> [Placement] -> NodeList
153 applySolution nl il sol =
154 let odxes = map (\ (a, b, c, _) -> (Container.find a il,
155 Node.idx (Container.find b nl),
156 Node.idx (Container.find c nl))
158 idxes = (\ (x, _, _) -> x) (unzip3 odxes)
159 nc = removeInstances nl idxes
161 foldl' (\ nz (a, b, c) ->
162 let new_p = Container.find b nz
163 new_s = Container.find c nz in
164 fromJust (addInstance nz a new_p new_s)
168 -- First phase functions
170 {- | Given a list 1,2,3..n build a list of pairs [(1, [2..n]), (2,
174 genParts :: [a] -> Int -> [(a, [a])]
179 if length l < count then
182 (x, xs) : (genParts xs count)
184 -- | Generates combinations of count items from the names list.
185 genNames :: Int -> [b] -> [[b]]
186 genNames count1 names1 =
187 let aux_fn count names current =
192 (\ (x, xs) -> aux_fn (count - 1) xs (x:current))
193 (genParts names count)
195 aux_fn count1 names1 []
197 {- | Computes the pair of bad nodes and instances.
199 The bad node list is computed via a simple 'verifyN1' check, and the
200 bad instance list is the list of primary and secondary instances of
204 computeBadItems :: NodeList -> InstanceList ->
205 ([Node.Node], [Instance.Instance])
206 computeBadItems nl il =
207 let bad_nodes = verifyN1 $ filter (not . Node.offline) $ Container.elems nl
208 bad_instances = map (\idx -> Container.find idx il) $
209 sort $ nub $ concat $
210 map (\ n -> (Node.slist n) ++ (Node.plist n)) bad_nodes
212 (bad_nodes, bad_instances)
215 {- | Checks if removal of instances results in N+1 pass.
217 Note: the check removal cannot optimize by scanning only the affected
218 nodes, since the cluster is known to be not healthy; only the check
219 placement can make this shortcut.
222 checkRemoval :: NodeList -> [Instance.Instance] -> Maybe Removal
223 checkRemoval nl victims =
224 let nx = removeInstances nl victims
225 failN1 = verifyN1Check (Container.elems nx)
230 Just $ Removal nx victims
233 -- | Computes the removals list for a given depth
234 computeRemovals :: NodeList
235 -> [Instance.Instance]
238 computeRemovals nl bad_instances depth =
239 map (checkRemoval nl) $ genNames depth bad_instances
241 -- Second phase functions
243 -- | Single-node relocation cost
244 nodeDelta :: Int -> Int -> Int -> Int
246 if i == p || i == s then
251 {-| Compute best solution.
253 This function compares two solutions, choosing the minimum valid
256 compareSolutions :: Maybe Solution -> Maybe Solution -> Maybe Solution
257 compareSolutions a b = case (a, b) of
262 -- | Compute best table. Note that the ordering of the arguments is important.
263 compareTables :: Table -> Table -> Table
264 compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
265 if a_cv > b_cv then b else a
267 -- | Check if a given delta is worse then an existing solution.
268 tooHighDelta :: Maybe Solution -> Int -> Int -> Bool
269 tooHighDelta sol new_delta max_delta =
270 if new_delta > max_delta && max_delta >=0 then
275 Just (Solution old_delta _) -> old_delta <= new_delta
277 {-| Check if placement of instances still keeps the cluster N+1 compliant.
279 This is the workhorse of the allocation algorithm: given the
280 current node and instance maps, the list of instances to be
281 placed, and the current solution, this will return all possible
282 solution by recursing until all target instances are placed.
285 checkPlacement :: NodeList -- ^ The current node list
286 -> [Instance.Instance] -- ^ List of instances still to place
287 -> [Placement] -- ^ Partial solution until now
288 -> Int -- ^ The delta of the partial solution
289 -> Maybe Solution -- ^ The previous solution
290 -> Int -- ^ Abort if the we go above this delta
291 -> Maybe Solution -- ^ The new solution
292 checkPlacement nl victims current current_delta prev_sol max_delta =
293 let target = head victims
294 opdx = Instance.pnode target
295 osdx = Instance.snode target
297 have_tail = (length vtail) > 0
298 nodes = Container.elems nl
299 iidx = Instance.idx target
304 pri_idx = Node.idx pri
305 upri_delta = current_delta + nodeDelta pri_idx opdx osdx
306 new_pri = Node.addPri pri target
307 fail_delta1 = tooHighDelta accu_p upri_delta max_delta
309 if fail_delta1 || isNothing(new_pri) then accu_p
310 else let pri_nl = Container.add pri_idx (fromJust new_pri) nl in
314 sec_idx = Node.idx sec
315 upd_delta = upri_delta +
316 nodeDelta sec_idx opdx osdx
317 fail_delta2 = tooHighDelta accu upd_delta max_delta
318 new_sec = Node.addSec sec target pri_idx
320 if sec_idx == pri_idx || fail_delta2 ||
321 isNothing new_sec then accu
323 nx = Container.add sec_idx (fromJust new_sec) pri_nl
325 plc = (iidx, pri_idx, sec_idx, upd_cv)
329 checkPlacement nx vtail c2 upd_delta
332 Just (Solution upd_delta c2)
333 in compareSolutions accu result
338 applyMove :: NodeList -> Instance.Instance
339 -> IMove -> (Maybe NodeList, Instance.Instance, Int, Int)
341 applyMove nl inst Failover =
342 let old_pdx = Instance.pnode inst
343 old_sdx = Instance.snode inst
344 old_p = Container.find old_pdx nl
345 old_s = Container.find old_sdx nl
346 int_p = Node.removePri old_p inst
347 int_s = Node.removeSec old_s inst
348 new_nl = do -- Maybe monad
349 new_p <- Node.addPri int_s inst
350 new_s <- Node.addSec int_p inst old_sdx
351 return $ Container.addTwo old_pdx new_s old_sdx new_p nl
352 in (new_nl, Instance.setBoth inst old_sdx old_pdx, old_sdx, old_pdx)
354 -- Replace the primary (f:, r:np, f)
355 applyMove nl inst (ReplacePrimary new_pdx) =
356 let old_pdx = Instance.pnode inst
357 old_sdx = Instance.snode inst
358 old_p = Container.find old_pdx nl
359 old_s = Container.find old_sdx nl
360 tgt_n = Container.find new_pdx nl
361 int_p = Node.removePri old_p inst
362 int_s = Node.removeSec old_s inst
363 new_nl = do -- Maybe monad
364 new_p <- Node.addPri tgt_n inst
365 new_s <- Node.addSec int_s inst new_pdx
366 return $ Container.add new_pdx new_p $
367 Container.addTwo old_pdx int_p old_sdx new_s nl
368 in (new_nl, Instance.setPri inst new_pdx, new_pdx, old_sdx)
370 -- Replace the secondary (r:ns)
371 applyMove nl inst (ReplaceSecondary new_sdx) =
372 let old_pdx = Instance.pnode inst
373 old_sdx = Instance.snode inst
374 old_s = Container.find old_sdx nl
375 tgt_n = Container.find new_sdx nl
376 int_s = Node.removeSec old_s inst
377 new_nl = Node.addSec tgt_n inst old_pdx >>=
378 \new_s -> return $ Container.addTwo new_sdx
379 new_s old_sdx int_s nl
380 in (new_nl, Instance.setSec inst new_sdx, old_pdx, new_sdx)
382 -- Replace the secondary and failover (r:np, f)
383 applyMove nl inst (ReplaceAndFailover new_pdx) =
384 let old_pdx = Instance.pnode inst
385 old_sdx = Instance.snode inst
386 old_p = Container.find old_pdx nl
387 old_s = Container.find old_sdx nl
388 tgt_n = Container.find new_pdx nl
389 int_p = Node.removePri old_p inst
390 int_s = Node.removeSec old_s inst
391 new_nl = do -- Maybe monad
392 new_p <- Node.addPri tgt_n inst
393 new_s <- Node.addSec int_p inst new_pdx
394 return $ Container.add new_pdx new_p $
395 Container.addTwo old_pdx new_s old_sdx int_s nl
396 in (new_nl, Instance.setBoth inst new_pdx old_pdx, new_pdx, old_pdx)
398 -- Failver and replace the secondary (f, r:ns)
399 applyMove nl inst (FailoverAndReplace new_sdx) =
400 let old_pdx = Instance.pnode inst
401 old_sdx = Instance.snode inst
402 old_p = Container.find old_pdx nl
403 old_s = Container.find old_sdx nl
404 tgt_n = Container.find new_sdx nl
405 int_p = Node.removePri old_p inst
406 int_s = Node.removeSec old_s inst
407 new_nl = do -- Maybe monad
408 new_p <- Node.addPri int_s inst
409 new_s <- Node.addSec tgt_n inst old_sdx
410 return $ Container.add new_sdx new_s $
411 Container.addTwo old_sdx new_p old_pdx int_p nl
412 in (new_nl, Instance.setBoth inst old_sdx new_sdx, old_sdx, new_sdx)
414 checkSingleStep :: Table -- ^ The original table
415 -> Instance.Instance -- ^ The instance to move
416 -> Table -- ^ The current best table
417 -> IMove -- ^ The move to apply
418 -> Table -- ^ The final best table
419 checkSingleStep ini_tbl target cur_tbl move =
421 Table ini_nl ini_il _ ini_plc = ini_tbl
422 (tmp_nl, new_inst, pri_idx, sec_idx) = applyMove ini_nl target move
424 if isNothing tmp_nl then cur_tbl
426 let tgt_idx = Instance.idx target
427 upd_nl = fromJust tmp_nl
428 upd_cvar = compCV upd_nl
429 upd_il = Container.add tgt_idx new_inst ini_il
430 upd_plc = (tgt_idx, pri_idx, sec_idx, upd_cvar):ini_plc
431 upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
433 compareTables cur_tbl upd_tbl
435 -- | Given the status of the current secondary as a valid new node
436 -- and the current candidate target node,
437 -- generate the possible moves for a instance.
438 possibleMoves :: Bool -> Int -> [IMove]
439 possibleMoves True tdx =
440 [ReplaceSecondary tdx,
441 ReplaceAndFailover tdx,
443 FailoverAndReplace tdx]
445 possibleMoves False tdx =
446 [ReplaceSecondary tdx,
447 ReplaceAndFailover tdx]
449 -- | Compute the best move for a given instance.
450 checkInstanceMove :: [Int] -- Allowed target node indices
451 -> Table -- Original table
452 -> Instance.Instance -- Instance to move
453 -> Table -- Best new table for this instance
454 checkInstanceMove nodes_idx ini_tbl target =
456 opdx = Instance.pnode target
457 osdx = Instance.snode target
458 nodes = filter (\idx -> idx /= opdx && idx /= osdx) nodes_idx
459 use_secondary = elem osdx nodes_idx
460 aft_failover = if use_secondary -- if allowed to failover
461 then checkSingleStep ini_tbl target ini_tbl Failover
463 all_moves = concatMap (possibleMoves use_secondary) nodes
465 -- iterate over the possible nodes for this instance
466 foldl' (checkSingleStep ini_tbl target) aft_failover all_moves
468 -- | Compute the best next move.
469 checkMove :: [Int] -- ^ Allowed target node indices
470 -> Table -- ^ The current solution
471 -> [Instance.Instance] -- ^ List of instances still to move
472 -> Table -- ^ The new solution
473 checkMove nodes_idx ini_tbl victims =
474 let Table _ _ _ ini_plc = ini_tbl
475 -- iterate over all instances, computing the best move
478 (\ step_tbl elem -> compareTables step_tbl $
479 checkInstanceMove nodes_idx ini_tbl elem)
481 Table _ _ _ best_plc = best_tbl
483 if length best_plc == length ini_plc then -- no advancement
488 {- | Auxiliary function for solution computation.
490 We write this in an explicit recursive fashion in order to control
491 early-abort in case we have met the min delta. We can't use foldr
492 instead of explicit recursion since we need the accumulator for the
496 advanceSolution :: [Maybe Removal] -- ^ The removal to process
497 -> Int -- ^ Minimum delta parameter
498 -> Int -- ^ Maximum delta parameter
499 -> Maybe Solution -- ^ Current best solution
500 -> Maybe Solution -- ^ New best solution
501 advanceSolution [] _ _ sol = sol
502 advanceSolution (Nothing:xs) m n sol = advanceSolution xs m n sol
503 advanceSolution ((Just (Removal nx removed)):xs) min_d max_d prev_sol =
504 let new_sol = checkPlacement nx removed [] 0 prev_sol max_d
505 new_delta = solutionDelta $! new_sol
507 if new_delta >= 0 && new_delta <= min_d then
510 advanceSolution xs min_d max_d new_sol
512 -- | Computes the placement solution.
513 solutionFromRemovals :: [Maybe Removal] -- ^ The list of (possible) removals
514 -> Int -- ^ Minimum delta parameter
515 -> Int -- ^ Maximum delta parameter
516 -> Maybe Solution -- ^ The best solution found
517 solutionFromRemovals removals min_delta max_delta =
518 advanceSolution removals min_delta max_delta Nothing
520 {- | Computes the solution at the given depth.
522 This is a wrapper over both computeRemovals and
523 solutionFromRemovals. In case we have no solution, we return Nothing.
526 computeSolution :: NodeList -- ^ The original node data
527 -> [Instance.Instance] -- ^ The list of /bad/ instances
528 -> Int -- ^ The /depth/ of removals
529 -> Int -- ^ Maximum number of removals to process
530 -> Int -- ^ Minimum delta parameter
531 -> Int -- ^ Maximum delta parameter
532 -> Maybe Solution -- ^ The best solution found (or Nothing)
533 computeSolution nl bad_instances depth max_removals min_delta max_delta =
535 removals = computeRemovals nl bad_instances depth
536 removals' = capRemovals removals max_removals
538 solutionFromRemovals removals' min_delta max_delta
540 -- Solution display functions (pure)
542 -- | Given the original and final nodes, computes the relocation description.
543 computeMoves :: String -- ^ The instance name
544 -> String -- ^ Original primary
545 -> String -- ^ Original secondary
546 -> String -- ^ New primary
547 -> String -- ^ New secondary
548 -> (String, [String])
549 -- ^ Tuple of moves and commands list; moves is containing
550 -- either @/f/@ for failover or @/r:name/@ for replace
551 -- secondary, while the command list holds gnt-instance
552 -- commands (without that prefix), e.g \"@failover instance1@\"
553 computeMoves i a b c d =
554 if c == a then {- Same primary -}
555 if d == b then {- Same sec??! -}
557 else {- Change of secondary -}
559 [printf "replace-disks -n %s %s" d i])
561 if c == b then {- Failover and ... -}
562 if d == a then {- that's all -}
563 ("f", [printf "migrate -f %s" i])
566 [printf "migrate -f %s" i,
567 printf "replace-disks -n %s %s" d i])
569 if d == a then {- ... and keep primary as secondary -}
571 [printf "replace-disks -n %s %s" c i,
572 printf "migrate -f %s" i])
574 if d == b then {- ... keep same secondary -}
575 (printf "f r:%s f" c,
576 [printf "migrate -f %s" i,
577 printf "replace-disks -n %s %s" c i,
578 printf "migrate -f %s" i])
580 else {- Nothing in common -}
581 (printf "r:%s f r:%s" c d,
582 [printf "replace-disks -n %s %s" c i,
583 printf "migrate -f %s" i,
584 printf "replace-disks -n %s %s" d i])
586 {-| Converts a placement to string format -}
587 printSolutionLine :: InstanceList
594 -> (String, [String])
595 printSolutionLine il ktn kti nmlen imlen plc pos =
597 pmlen = (2*nmlen + 1)
599 inst = Container.find i il
600 inam = fromJust $ lookup (Instance.idx inst) kti
601 npri = fromJust $ lookup p ktn
602 nsec = fromJust $ lookup s ktn
603 opri = fromJust $ lookup (Instance.pnode inst) ktn
604 osec = fromJust $ lookup (Instance.snode inst) ktn
605 (moves, cmds) = computeMoves inam opri osec npri nsec
606 ostr = (printf "%s:%s" opri osec)::String
607 nstr = (printf "%s:%s" npri nsec)::String
609 (printf " %3d. %-*s %-*s => %-*s %.8f a=%s"
610 pos imlen inam pmlen ostr
614 formatCmds :: [[String]] -> String
615 formatCmds cmd_strs =
617 concat $ map (\(a, b) ->
618 (printf "echo step %d" (a::Int)):
620 (map ("gnt-instance " ++) b)) $
623 {-| Converts a solution to string format -}
624 printSolution :: InstanceList
628 -> ([String], [[String]])
629 printSolution il ktn kti sol =
631 mlen_fn = maximum . (map length) . snd . unzip
635 unzip $ map (uncurry $ printSolutionLine il ktn kti nmlen imlen) $
638 -- | Print the node list.
639 printNodes :: NameList -> NodeList -> String
641 let snl = sortBy (compare `on` Node.idx) (Container.elems nl)
642 snl' = map (\ n -> ((fromJust $ lookup (Node.idx n) ktn), n)) snl
643 m_name = maximum . (map length) . fst . unzip $ snl'
644 helper = Node.list m_name
646 "%2s %-*s %5s %5s %5s %5s %5s %5s %5s %5s %3s %3s %7s %7s"
648 "t_mem" "n_mem" "i_mem" "x_mem" "f_mem" "r_mem"
650 "pri" "sec" "p_fmem" "p_fdsk"
651 in unlines $ (header:map (uncurry helper) snl')
653 -- | Compute the mem and disk covariance.
654 compDetailedCV :: NodeList -> (Double, Double, Double, Double, Double)
657 all_nodes = Container.elems nl
658 (offline, nodes) = partition Node.offline all_nodes
659 mem_l = map Node.p_mem nodes
660 dsk_l = map Node.p_dsk nodes
661 mem_cv = varianceCoeff mem_l
662 dsk_cv = varianceCoeff dsk_l
663 n1_l = length $ filter Node.failN1 nodes
664 n1_score = (fromIntegral n1_l) / (fromIntegral $ length nodes)
665 res_l = map Node.p_rem nodes
666 res_cv = varianceCoeff res_l
667 offline_inst = sum . map (\n -> (length . Node.plist $ n) +
668 (length . Node.slist $ n)) $ offline
669 online_inst = sum . map (\n -> (length . Node.plist $ n) +
670 (length . Node.slist $ n)) $ nodes
671 off_score = (fromIntegral offline_inst) /
672 (fromIntegral $ online_inst + offline_inst)
673 in (mem_cv, dsk_cv, n1_score, res_cv, off_score)
675 -- | Compute the 'total' variance.
676 compCV :: NodeList -> Double
678 let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
679 in mem_cv + dsk_cv + n1_score + res_cv + off_score
681 printStats :: NodeList -> String
683 let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
684 in printf "f_mem=%.8f, r_mem=%.8f, f_dsk=%.8f, n1=%.3f, uf=%.3f"
685 mem_cv res_cv dsk_cv n1_score off_score
687 -- Balancing functions
691 {- | Convert newline and delimiter-separated text.
693 This function converts a text in tabular format as generated by
694 @gnt-instance list@ and @gnt-node list@ to a list of objects using a
695 supplied conversion function.
698 loadTabular :: (Monad m) => String -> ([String] -> m (String, a))
699 -> (a -> Int -> a) -> m ([(String, Int)], [(Int, a)])
700 loadTabular text_data convert_fn set_fn = do
701 let lines_data = lines text_data
702 rows = map (sepSplit '|') lines_data
703 kerows <- mapM convert_fn rows
704 let idxrows = map (\ (idx, (k, v)) -> ((k, idx), (idx, set_fn v idx)))
706 return $ unzip idxrows
708 -- | For each instance, add its index to its primary and secondary nodes
709 fixNodes :: [(Int, Node.Node)]
710 -> [(Int, Instance.Instance)]
711 -> [(Int, Node.Node)]
713 foldl' (\accu (idx, inst) ->
715 assocEqual = (\ (i, _) (j, _) -> i == j)
716 pdx = Instance.pnode inst
717 sdx = Instance.snode inst
718 pold = fromJust $ lookup pdx accu
719 sold = fromJust $ lookup sdx accu
720 pnew = Node.setPri pold idx
721 snew = Node.setSec sold idx
722 ac1 = deleteBy assocEqual (pdx, pold) accu
723 ac2 = deleteBy assocEqual (sdx, sold) ac1
724 ac3 = (pdx, pnew):(sdx, snew):ac2
727 -- | Compute the longest common suffix of a NameList list that
728 -- | starts with a dot
729 longestDomain :: NameList -> String
730 longestDomain [] = ""
731 longestDomain ((_,x):xs) =
733 onlyStrings = snd $ unzip xs
735 foldr (\ suffix accu -> if all (isSuffixOf suffix) onlyStrings
738 "" $ filter (isPrefixOf ".") (tails x)
740 -- | Remove tails from the (Int, String) lists
741 stripSuffix :: String -> NameList -> NameList
742 stripSuffix suffix lst =
743 let sflen = length suffix in
744 map (\ (key, name) -> (key, take ((length name) - sflen) name)) lst
746 -- | Safe 'read' function returning data encapsulated in a Result
747 tryRead :: (Monad m, Read a) => String -> String -> m a
749 let sols = readsPrec 0 s
751 (v, ""):[] -> return v
752 (_, e):[] -> fail $ name ++ ": leftover characters when parsing '"
753 ++ s ++ "': '" ++ e ++ "'"
754 _ -> fail $ name ++ ": cannot parse string '" ++ s ++ "'"
756 -- | Lookups a node into an assoc list
757 lookupNode :: (Monad m) => String -> String -> [(String, Int)] -> m Int
758 lookupNode node inst ktn =
759 case lookup node ktn of
760 Nothing -> fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst
761 Just idx -> return idx
763 -- | Load a node from a field list
764 loadNode :: (Monad m) => [String] -> m (String, Node.Node)
765 loadNode (name:tm:nm:fm:td:fd:fo:[]) = do
767 if any (== "?") [tm,nm,fm,td,fd] || fo == "Y" then
768 return $ Node.create 0 0 0 0 0 True
770 vtm <- tryRead name tm
771 vnm <- tryRead name nm
772 vfm <- tryRead name fm
773 vtd <- tryRead name td
774 vfd <- tryRead name fd
775 return $ Node.create vtm vnm vfm vtd vfd False
776 return (name, new_node)
777 loadNode s = fail $ "Invalid/incomplete node data: '" ++ (show s) ++ "'"
779 -- | Load an instance from a field list
780 loadInst :: (Monad m) =>
781 [(String, Int)] -> [String] -> m (String, Instance.Instance)
782 loadInst ktn (name:mem:dsk:status:pnode:snode:[]) = do
783 pidx <- lookupNode pnode name ktn
784 sidx <- lookupNode snode name ktn
785 vmem <- tryRead name mem
786 vdsk <- tryRead name dsk
787 when (sidx == pidx) $ fail $ "Instance " ++ name ++
788 " has same primary and secondary node - " ++ pnode
789 let newinst = Instance.create vmem vdsk status pidx sidx
790 return (name, newinst)
791 loadInst _ s = fail $ "Invalid/incomplete instance data: '" ++ (show s) ++ "'"
793 {-| Initializer function that loads the data from a node and list file
794 and massages it into the correct format. -}
795 loadData :: String -- ^ Node data in text format
796 -> String -- ^ Instance data in text format
797 -> Result (Container.Container Node.Node,
798 Container.Container Instance.Instance,
799 String, NameList, NameList)
800 loadData ndata idata = do
801 {- node file: name t_mem n_mem f_mem t_disk f_disk -}
802 (ktn, nl) <- loadTabular ndata loadNode Node.setIdx
803 {- instance file: name mem disk status pnode snode -}
804 (kti, il) <- loadTabular idata (loadInst ktn) Instance.setIdx
807 il3 = Container.fromAssocList il
808 nl3 = Container.fromAssocList
809 (map (\ (k, v) -> (k, Node.buildPeers v il3 (length nl2))) nl2)
812 common_suffix = longestDomain (xti ++ xtn)
813 stn = stripSuffix common_suffix xtn
814 sti = stripSuffix common_suffix xti
815 return (nl3, il3, common_suffix, stn, sti)
817 -- | Compute the amount of memory used by primary instances on a node.
818 nodeImem :: Node.Node -> InstanceList -> Int
820 let rfind = flip Container.find $ il
821 in sum . map Instance.mem .
822 map rfind $ Node.plist node
824 -- | Compute the amount of disk used by instances on a node (either primary
826 nodeIdsk :: Node.Node -> InstanceList -> Int
828 let rfind = flip Container.find $ il
829 in sum . map Instance.dsk .
830 map rfind $ (Node.plist node) ++ (Node.slist node)
832 -- | Check cluster data for consistency
833 checkData :: NodeList -> InstanceList -> NameList -> NameList
834 -> ([String], NodeList)
835 checkData nl il ktn _ =
838 let nname = fromJust $ lookup (Node.idx node) ktn
839 nilst = map (flip Container.find $ il) (Node.plist node)
840 dilst = filter (not . Instance.running) nilst
841 adj_mem = sum . map Instance.mem $ dilst
842 delta_mem = (truncate $ Node.t_mem node)
847 delta_dsk = (truncate $ Node.t_dsk node)
850 newn = Node.setFmem (Node.setXmem node delta_mem)
851 (Node.f_mem node - adj_mem)
852 umsg1 = if delta_mem > 512 || delta_dsk > 1024
853 then [printf "node %s is missing %d MB ram \
855 nname delta_mem (delta_dsk `div` 1024)]
857 in (msgs ++ umsg1, newn)