Remove use of 'head' and add hlint warning for it
[ganeti-github.git] / src / Ganeti / HTools / Program / Hspace.hs
1 {-| Cluster space sizing
2
3 -}
4
5 {-
6
7 Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
8
9 This program is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 2 of the License, or
12 (at your option) any later version.
13
14 This program is distributed in the hope that it will be useful, but
15 WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 General Public License for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with this program; if not, write to the Free Software
21 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
22 02110-1301, USA.
23
24 -}
25
26 module Ganeti.HTools.Program.Hspace
27 (main
28 , options
29 , arguments
30 ) where
31
32 import Control.Monad
33 import Data.Char (toUpper, toLower)
34 import Data.Function (on)
35 import Data.List
36 import Data.Maybe (fromMaybe)
37 import Data.Ord (comparing)
38 import System.IO
39
40 import Text.Printf (printf, hPrintf)
41
42 import qualified Ganeti.HTools.Container as Container
43 import qualified Ganeti.HTools.Cluster as Cluster
44 import qualified Ganeti.HTools.Node as Node
45 import qualified Ganeti.HTools.Instance as Instance
46
47 import Ganeti.BasicTypes
48 import Ganeti.Common
49 import Ganeti.HTools.Types
50 import Ganeti.HTools.CLI
51 import Ganeti.HTools.ExtLoader
52 import Ganeti.HTools.Loader
53 import Ganeti.Utils
54
55 -- | Options list and functions.
56 options :: IO [OptType]
57 options = do
58 luxi <- oLuxiSocket
59 return
60 [ oPrintNodes
61 , oDataFile
62 , oDiskTemplate
63 , oSpindleUse
64 , oNodeSim
65 , oRapiMaster
66 , luxi
67 , oIAllocSrc
68 , oVerbose
69 , oQuiet
70 , oOfflineNode
71 , oMachineReadable
72 , oMaxCpu
73 , oMaxSolLength
74 , oMinDisk
75 , oStdSpec
76 , oTieredSpec
77 , oSaveCluster
78 ]
79
80 -- | The list of arguments supported by the program.
81 arguments :: [ArgCompletion]
82 arguments = []
83
84 -- | The allocation phase we're in (initial, after tiered allocs, or
85 -- after regular allocation).
86 data Phase = PInitial
87 | PFinal
88 | PTiered
89
90 -- | The kind of instance spec we print.
91 data SpecType = SpecNormal
92 | SpecTiered
93
94 -- | Prefix for machine readable names
95 htsPrefix :: String
96 htsPrefix = "HTS"
97
98 -- | What we prefix a spec with.
99 specPrefix :: SpecType -> String
100 specPrefix SpecNormal = "SPEC"
101 specPrefix SpecTiered = "TSPEC_INI"
102
103 -- | The description of a spec.
104 specDescription :: SpecType -> String
105 specDescription SpecNormal = "Standard (fixed-size)"
106 specDescription SpecTiered = "Tiered (initial size)"
107
108 -- | The \"name\" of a 'SpecType'.
109 specName :: SpecType -> String
110 specName SpecNormal = "Standard"
111 specName SpecTiered = "Tiered"
112
113 -- | Efficiency generic function.
114 effFn :: (Cluster.CStats -> Integer)
115 -> (Cluster.CStats -> Double)
116 -> Cluster.CStats -> Double
117 effFn fi ft cs = fromIntegral (fi cs) / ft cs
118
119 -- | Memory efficiency.
120 memEff :: Cluster.CStats -> Double
121 memEff = effFn Cluster.csImem Cluster.csTmem
122
123 -- | Disk efficiency.
124 dskEff :: Cluster.CStats -> Double
125 dskEff = effFn Cluster.csIdsk Cluster.csTdsk
126
127 -- | Cpu efficiency.
128 cpuEff :: Cluster.CStats -> Double
129 cpuEff = effFn Cluster.csIcpu (fromIntegral . Cluster.csVcpu)
130
131 -- | Holds data for converting a 'Cluster.CStats' structure into
132 -- detailed statistics.
133 statsData :: [(String, Cluster.CStats -> String)]
134 statsData = [ ("SCORE", printf "%.8f" . Cluster.csScore)
135 , ("INST_CNT", printf "%d" . Cluster.csNinst)
136 , ("MEM_FREE", printf "%d" . Cluster.csFmem)
137 , ("MEM_AVAIL", printf "%d" . Cluster.csAmem)
138 , ("MEM_RESVD",
139 \cs -> printf "%d" (Cluster.csFmem cs - Cluster.csAmem cs))
140 , ("MEM_INST", printf "%d" . Cluster.csImem)
141 , ("MEM_OVERHEAD",
142 \cs -> printf "%d" (Cluster.csXmem cs + Cluster.csNmem cs))
143 , ("MEM_EFF", printf "%.8f" . memEff)
144 , ("DSK_FREE", printf "%d" . Cluster.csFdsk)
145 , ("DSK_AVAIL", printf "%d". Cluster.csAdsk)
146 , ("DSK_RESVD",
147 \cs -> printf "%d" (Cluster.csFdsk cs - Cluster.csAdsk cs))
148 , ("DSK_INST", printf "%d" . Cluster.csIdsk)
149 , ("DSK_EFF", printf "%.8f" . dskEff)
150 , ("CPU_INST", printf "%d" . Cluster.csIcpu)
151 , ("CPU_EFF", printf "%.8f" . cpuEff)
152 , ("MNODE_MEM_AVAIL", printf "%d" . Cluster.csMmem)
153 , ("MNODE_DSK_AVAIL", printf "%d" . Cluster.csMdsk)
154 ]
155
156 -- | List holding 'RSpec' formatting information.
157 specData :: [(String, RSpec -> String)]
158 specData = [ ("MEM", printf "%d" . rspecMem)
159 , ("DSK", printf "%d" . rspecDsk)
160 , ("CPU", printf "%d" . rspecCpu)
161 ]
162
163 -- | List holding 'Cluster.CStats' formatting information.
164 clusterData :: [(String, Cluster.CStats -> String)]
165 clusterData = [ ("MEM", printf "%.0f" . Cluster.csTmem)
166 , ("DSK", printf "%.0f" . Cluster.csTdsk)
167 , ("CPU", printf "%.0f" . Cluster.csTcpu)
168 , ("VCPU", printf "%d" . Cluster.csVcpu)
169 ]
170
171 -- | Function to print stats for a given phase.
172 printStats :: Phase -> Cluster.CStats -> [(String, String)]
173 printStats ph cs =
174 map (\(s, fn) -> (printf "%s_%s" kind s, fn cs)) statsData
175 where kind = case ph of
176 PInitial -> "INI"
177 PFinal -> "FIN"
178 PTiered -> "TRL"
179
180 -- | Print failure reason and scores
181 printFRScores :: Node.List -> Node.List -> [(FailMode, Int)] -> IO ()
182 printFRScores ini_nl fin_nl sreason = do
183 printf " - most likely failure reason: %s\n" $ failureReason sreason::IO ()
184 printClusterScores ini_nl fin_nl
185 printClusterEff (Cluster.totalResources fin_nl)
186
187 -- | Print final stats and related metrics.
188 printResults :: Bool -> Node.List -> Node.List -> Int -> Int
189 -> [(FailMode, Int)] -> IO ()
190 printResults True _ fin_nl num_instances allocs sreason = do
191 let fin_stats = Cluster.totalResources fin_nl
192 fin_instances = num_instances + allocs
193
194 exitWhen (num_instances + allocs /= Cluster.csNinst fin_stats) $
195 printf "internal inconsistency, allocated (%d)\
196 \ != counted (%d)\n" (num_instances + allocs)
197 (Cluster.csNinst fin_stats)
198
199 main_reason <- exitIfEmpty "Internal error, no failure reasons?!" sreason
200
201 printKeysHTS $ printStats PFinal fin_stats
202 printKeysHTS [ ("ALLOC_USAGE", printf "%.8f"
203 ((fromIntegral num_instances::Double) /
204 fromIntegral fin_instances))
205 , ("ALLOC_INSTANCES", printf "%d" allocs)
206 , ("ALLOC_FAIL_REASON", map toUpper . show . fst $ main_reason)
207 ]
208 printKeysHTS $ map (\(x, y) -> (printf "ALLOC_%s_CNT" (show x),
209 printf "%d" y)) sreason
210
211 printResults False ini_nl fin_nl _ allocs sreason = do
212 putStrLn "Normal (fixed-size) allocation results:"
213 printf " - %3d instances allocated\n" allocs :: IO ()
214 printFRScores ini_nl fin_nl sreason
215
216 -- | Prints the final @OK@ marker in machine readable output.
217 printFinalHTS :: Bool -> IO ()
218 printFinalHTS = printFinal htsPrefix
219
220 {-# ANN tieredSpecMap "HLint: ignore Use alternative" #-}
221 -- | Compute the tiered spec counts from a list of allocated
222 -- instances.
223 tieredSpecMap :: [Instance.Instance]
224 -> [(RSpec, Int)]
225 tieredSpecMap trl_ixes =
226 let fin_trl_ixes = reverse trl_ixes
227 ix_byspec = groupBy ((==) `on` Instance.specOf) fin_trl_ixes
228 -- head is "safe" here, as groupBy returns list of non-empty lists
229 spec_map = map (\ixs -> (Instance.specOf $ head ixs, length ixs))
230 ix_byspec
231 in spec_map
232
233 -- | Formats a spec map to strings.
234 formatSpecMap :: [(RSpec, Int)] -> [String]
235 formatSpecMap =
236 map (\(spec, cnt) -> printf "%d,%d,%d=%d" (rspecMem spec)
237 (rspecDsk spec) (rspecCpu spec) cnt)
238
239 -- | Formats \"key-metrics\" values.
240 formatRSpec :: String -> AllocInfo -> [(String, String)]
241 formatRSpec s r =
242 [ ("KM_" ++ s ++ "_CPU", show $ allocInfoVCpus r)
243 , ("KM_" ++ s ++ "_NPU", show $ allocInfoNCpus r)
244 , ("KM_" ++ s ++ "_MEM", show $ allocInfoMem r)
245 , ("KM_" ++ s ++ "_DSK", show $ allocInfoDisk r)
246 ]
247
248 -- | Shows allocations stats.
249 printAllocationStats :: Node.List -> Node.List -> IO ()
250 printAllocationStats ini_nl fin_nl = do
251 let ini_stats = Cluster.totalResources ini_nl
252 fin_stats = Cluster.totalResources fin_nl
253 (rini, ralo, runa) = Cluster.computeAllocationDelta ini_stats fin_stats
254 printKeysHTS $ formatRSpec "USED" rini
255 printKeysHTS $ formatRSpec "POOL" ralo
256 printKeysHTS $ formatRSpec "UNAV" runa
257
258 -- | Format a list of key\/values as a shell fragment.
259 printKeysHTS :: [(String, String)] -> IO ()
260 printKeysHTS = printKeys htsPrefix
261
262 -- | Converts instance data to a list of strings.
263 printInstance :: Node.List -> Instance.Instance -> [String]
264 printInstance nl i = [ Instance.name i
265 , Container.nameOf nl $ Instance.pNode i
266 , let sdx = Instance.sNode i
267 in if sdx == Node.noSecondary then ""
268 else Container.nameOf nl sdx
269 , show (Instance.mem i)
270 , show (Instance.dsk i)
271 , show (Instance.vcpus i)
272 ]
273
274 -- | Optionally print the allocation map.
275 printAllocationMap :: Int -> String
276 -> Node.List -> [Instance.Instance] -> IO ()
277 printAllocationMap verbose msg nl ixes =
278 when (verbose > 1) $ do
279 hPutStrLn stderr (msg ++ " map")
280 hPutStr stderr . unlines . map ((:) ' ' . unwords) $
281 formatTable (map (printInstance nl) (reverse ixes))
282 -- This is the numberic-or-not field
283 -- specification; the first three fields are
284 -- strings, whereas the rest are numeric
285 [False, False, False, True, True, True]
286
287 -- | Formats nicely a list of resources.
288 formatResources :: a -> [(String, a->String)] -> String
289 formatResources res =
290 intercalate ", " . map (\(a, fn) -> a ++ " " ++ fn res)
291
292 -- | Print the cluster resources.
293 printCluster :: Bool -> Cluster.CStats -> Int -> IO ()
294 printCluster True ini_stats node_count = do
295 printKeysHTS $ map (\(a, fn) -> ("CLUSTER_" ++ a, fn ini_stats)) clusterData
296 printKeysHTS [("CLUSTER_NODES", printf "%d" node_count)]
297 printKeysHTS $ printStats PInitial ini_stats
298
299 printCluster False ini_stats node_count = do
300 printf "The cluster has %d nodes and the following resources:\n %s.\n"
301 node_count (formatResources ini_stats clusterData)::IO ()
302 printf "There are %s initial instances on the cluster.\n"
303 (if inst_count > 0 then show inst_count else "no" )
304 where inst_count = Cluster.csNinst ini_stats
305
306 -- | Prints the normal instance spec.
307 printISpec :: Bool -> RSpec -> SpecType -> DiskTemplate -> IO ()
308 printISpec True ispec spec disk_template = do
309 printKeysHTS $ map (\(a, fn) -> (prefix ++ "_" ++ a, fn ispec)) specData
310 printKeysHTS [ (prefix ++ "_RQN", printf "%d" req_nodes) ]
311 printKeysHTS [ (prefix ++ "_DISK_TEMPLATE",
312 diskTemplateToRaw disk_template) ]
313 where req_nodes = Instance.requiredNodes disk_template
314 prefix = specPrefix spec
315
316 printISpec False ispec spec disk_template =
317 printf "%s instance spec is:\n %s, using disk\
318 \ template '%s'.\n"
319 (specDescription spec)
320 (formatResources ispec specData) (diskTemplateToRaw disk_template)
321
322 -- | Prints the tiered results.
323 printTiered :: Bool -> [(RSpec, Int)]
324 -> Node.List -> Node.List -> [(FailMode, Int)] -> IO ()
325 printTiered True spec_map nl trl_nl _ = do
326 printKeysHTS $ printStats PTiered (Cluster.totalResources trl_nl)
327 printKeysHTS [("TSPEC", unwords (formatSpecMap spec_map))]
328 printAllocationStats nl trl_nl
329
330 printTiered False spec_map ini_nl fin_nl sreason = do
331 _ <- printf "Tiered allocation results:\n"
332 if null spec_map
333 then putStrLn " - no instances allocated"
334 else mapM_ (\(ispec, cnt) ->
335 printf " - %3d instances of spec %s\n" cnt
336 (formatResources ispec specData)) spec_map
337 printFRScores ini_nl fin_nl sreason
338
339 -- | Displays the initial/final cluster scores.
340 printClusterScores :: Node.List -> Node.List -> IO ()
341 printClusterScores ini_nl fin_nl = do
342 printf " - initial cluster score: %.8f\n" $ Cluster.compCV ini_nl::IO ()
343 printf " - final cluster score: %.8f\n" $ Cluster.compCV fin_nl
344
345 -- | Displays the cluster efficiency.
346 printClusterEff :: Cluster.CStats -> IO ()
347 printClusterEff cs =
348 mapM_ (\(s, fn) ->
349 printf " - %s usage efficiency: %5.2f%%\n" s (fn cs * 100))
350 [("memory", memEff),
351 (" disk", dskEff),
352 (" vcpu", cpuEff)]
353
354 -- | Computes the most likely failure reason.
355 failureReason :: [(FailMode, Int)] -> String
356 failureReason = show . fst . head
357
358 -- | Sorts the failure reasons.
359 sortReasons :: [(FailMode, Int)] -> [(FailMode, Int)]
360 sortReasons = reverse . sortBy (comparing snd)
361
362 -- | Runs an allocation algorithm and saves cluster state.
363 runAllocation :: ClusterData -- ^ Cluster data
364 -> Maybe Cluster.AllocResult -- ^ Optional stop-allocation
365 -> Result Cluster.AllocResult -- ^ Allocation result
366 -> RSpec -- ^ Requested instance spec
367 -> DiskTemplate -- ^ Requested disk template
368 -> SpecType -- ^ Allocation type
369 -> Options -- ^ CLI options
370 -> IO (FailStats, Node.List, Int, [(RSpec, Int)])
371 runAllocation cdata stop_allocation actual_result spec dt mode opts = do
372 (reasons, new_nl, new_il, new_ixes, _) <-
373 case stop_allocation of
374 Just result_noalloc -> return result_noalloc
375 Nothing -> exitIfBad "failure during allocation" actual_result
376
377 let name = specName mode
378 descr = name ++ " allocation"
379 ldescr = "after " ++ map toLower descr
380
381 printISpec (optMachineReadable opts) spec mode dt
382
383 printAllocationMap (optVerbose opts) descr new_nl new_ixes
384
385 maybePrintNodes (optShowNodes opts) descr (Cluster.printNodes new_nl)
386
387 maybeSaveData (optSaveCluster opts) (map toLower name) ldescr
388 (cdata { cdNodes = new_nl, cdInstances = new_il})
389
390 return (sortReasons reasons, new_nl, length new_ixes, tieredSpecMap new_ixes)
391
392 -- | Create an instance from a given spec.
393 instFromSpec :: RSpec -> DiskTemplate -> Int -> Instance.Instance
394 instFromSpec spx =
395 Instance.create "new" (rspecMem spx) (rspecDsk spx)
396 (rspecCpu spx) Running [] True (-1) (-1)
397
398 -- | Main function.
399 main :: Options -> [String] -> IO ()
400 main opts args = do
401 exitUnless (null args) "This program doesn't take any arguments."
402
403 let verbose = optVerbose opts
404 machine_r = optMachineReadable opts
405
406 orig_cdata@(ClusterData gl fixed_nl il _ ipol) <- loadExternalData opts
407 nl <- setNodeStatus opts fixed_nl
408
409 cluster_disk_template <-
410 case iPolicyDiskTemplates ipol of
411 first_templ:_ -> return first_templ
412 _ -> exitErr "null list of disk templates received from cluster"
413
414 let num_instances = Container.size il
415 all_nodes = Container.elems fixed_nl
416 cdata = orig_cdata { cdNodes = fixed_nl }
417 disk_template = fromMaybe cluster_disk_template (optDiskTemplate opts)
418 req_nodes = Instance.requiredNodes disk_template
419 csf = commonSuffix fixed_nl il
420 su = fromMaybe (iSpecSpindleUse $ iPolicyStdSpec ipol)
421 (optSpindleUse opts)
422
423 when (not (null csf) && verbose > 1) $
424 hPrintf stderr "Note: Stripping common suffix of '%s' from names\n" csf
425
426 maybePrintNodes (optShowNodes opts) "Initial cluster" (Cluster.printNodes nl)
427
428 when (verbose > 2) $
429 hPrintf stderr "Initial coefficients: overall %.8f\n%s"
430 (Cluster.compCV nl) (Cluster.printStats " " nl)
431
432 printCluster machine_r (Cluster.totalResources nl) (length all_nodes)
433
434 let stop_allocation = case Cluster.computeBadItems nl il of
435 ([], _) -> Nothing
436 _ -> Just ([(FailN1, 1)]::FailStats, nl, il, [], [])
437 alloclimit = if optMaxLength opts == -1
438 then Nothing
439 else Just (optMaxLength opts)
440
441 allocnodes <- exitIfBad "failure during allocation" $
442 Cluster.genAllocNodes gl nl req_nodes True
443
444 -- Run the tiered allocation
445
446 let tspec = fromMaybe (rspecFromISpec (iPolicyMaxSpec ipol))
447 (optTieredSpec opts)
448
449 (treason, trl_nl, _, spec_map) <-
450 runAllocation cdata stop_allocation
451 (Cluster.tieredAlloc nl il alloclimit
452 (instFromSpec tspec disk_template su) allocnodes [] [])
453 tspec disk_template SpecTiered opts
454
455 printTiered machine_r spec_map nl trl_nl treason
456
457 -- Run the standard (avg-mode) allocation
458
459 let ispec = fromMaybe (rspecFromISpec (iPolicyStdSpec ipol))
460 (optStdSpec opts)
461
462 (sreason, fin_nl, allocs, _) <-
463 runAllocation cdata stop_allocation
464 (Cluster.iterateAlloc nl il alloclimit
465 (instFromSpec ispec disk_template su) allocnodes [] [])
466 ispec disk_template SpecNormal opts
467
468 printResults machine_r nl fin_nl num_instances allocs sreason
469
470 -- Print final result
471
472 printFinalHTS machine_r