module Main (main) where
-import Data.Char (toUpper)
+import Data.Char (toUpper, isAlphaNum)
import Data.List
import Data.Function
+import Data.Maybe (isJust, fromJust)
+import Data.Ord (comparing)
import Monad
-import System
+import System (exitWith, ExitCode(..))
import System.IO
import qualified System
options :: [OptType]
options =
[ oPrintNodes
- , oNodeFile
- , oInstFile
+ , oDataFile
, oNodeSim
, oRapiMaster
, oLuxiSocket
, oShowHelp
]
-data Phase = PInitial | PFinal
+-- | The allocation phase we're in (initial, after tiered allocs, or
+-- after regular allocation).
+data Phase = PInitial
+ | PFinal
+ | PTiered
statsData :: [(String, Cluster.CStats -> String)]
statsData = [ ("SCORE", printf "%.8f" . Cluster.csScore)
\cs -> printf "%.8f" (fromIntegral (Cluster.csImem cs) /
Cluster.csTmem cs))
, ("DSK_FREE", printf "%d" . Cluster.csFdsk)
- , ("DSK_AVAIL", printf "%d ". Cluster.csAdsk)
+ , ("DSK_AVAIL", printf "%d". Cluster.csAdsk)
, ("DSK_RESVD",
\cs -> printf "%d" (Cluster.csFdsk cs - Cluster.csAdsk cs))
, ("DSK_INST", printf "%d" . Cluster.csIdsk)
clusterData = [ ("MEM", printf "%.0f" . Cluster.csTmem)
, ("DSK", printf "%.0f" . Cluster.csTdsk)
, ("CPU", printf "%.0f" . Cluster.csTcpu)
+ , ("VCPU", printf "%d" . Cluster.csVcpu)
]
-- | Recursively place instances on the cluster until we're out of space
Bad s -> Bad s
Ok (errs, _, sols3) ->
case sols3 of
- Nothing -> Ok (Cluster.collapseFailures errs, nl, ixes)
- Just (_, (xnl, xi, _)) ->
+ [] -> Ok (Cluster.collapseFailures errs, nl, ixes)
+ (_, (xnl, xi, _)):[] ->
iterateDepth xnl il newinst nreq $! (xi:ixes)
+ _ -> Bad "Internal error: multiple solutions for single\
+ \ allocation"
+
+tieredAlloc :: Node.List
+ -> Instance.List
+ -> Instance.Instance
+ -> Int
+ -> [Instance.Instance]
+ -> Result (FailStats, Node.List, [Instance.Instance])
+tieredAlloc nl il newinst nreq ixes =
+ case iterateDepth nl il newinst nreq ixes of
+ Bad s -> Bad s
+ Ok (errs, nl', ixes') ->
+ case Instance.shrinkByType newinst . fst . last $
+ sortBy (comparing snd) errs of
+ Bad _ -> Ok (errs, nl', ixes')
+ Ok newinst' ->
+ tieredAlloc nl' il newinst' nreq ixes'
+
-- | Function to print stats for a given phase
printStats :: Phase -> Cluster.CStats -> [(String, String)]
where kind = case ph of
PInitial -> "INI"
PFinal -> "FIN"
+ PTiered -> "TRL"
-- | Print final stats and related metrics
printResults :: Node.List -> Int -> Int -> [(FailMode, Int)] -> IO ()
do
hPrintf stderr "ERROR: internal inconsistency, allocated (%d)\
\ != counted (%d)\n" (num_instances + allocs)
- (Cluster.csNinst fin_stats)
+ (Cluster.csNinst fin_stats) :: IO ()
exitWith $ ExitFailure 1
printKeys $ printStats PFinal fin_stats
-- this should be the final entry
printKeys [("OK", "1")]
+formatRSpec :: String -> RSpec -> [(String, String)]
+formatRSpec s r =
+ [ ("KM_" ++ s ++ "_CPU", show $ rspecCpu r)
+ , ("KM_" ++ s ++ "_MEM", show $ rspecMem r)
+ , ("KM_" ++ s ++ "_DSK", show $ rspecDsk r)
+ ]
+
+printAllocationStats :: Node.List -> Node.List -> IO ()
+printAllocationStats ini_nl fin_nl = do
+ let ini_stats = Cluster.totalResources ini_nl
+ fin_stats = Cluster.totalResources fin_nl
+ (rini, ralo, runa) = Cluster.computeAllocationDelta ini_stats fin_stats
+ printKeys $ formatRSpec "USED" rini
+ printKeys $ formatRSpec "POOL" ralo
+ printKeys $ formatRSpec "UNAV" runa
+
+-- | Ensure a value is quoted if needed
+ensureQuoted :: String -> String
+ensureQuoted v = if not (all (\c -> (isAlphaNum c || c == '.')) v)
+ then '\'':v ++ "'"
+ else v
+
-- | Format a list of key/values as a shell fragment
printKeys :: [(String, String)] -> IO ()
-printKeys = mapM_ (\(k, v) -> printf "HTS_%s=%s\n" (map toUpper k) v)
+printKeys = mapM_ (\(k, v) ->
+ printf "HTS_%s=%s\n" (map toUpper k) (ensureQuoted v))
printInstance :: Node.List -> Instance.Instance -> [String]
printInstance nl i = [ Instance.name i
- , (Container.nameOf nl $ Instance.pNode i)
- , (let sdx = Instance.sNode i
- in if sdx == Node.noSecondary then ""
- else Container.nameOf nl sdx)
+ , Container.nameOf nl $ Instance.pNode i
+ , let sdx = Instance.sNode i
+ in if sdx == Node.noSecondary then ""
+ else Container.nameOf nl sdx
, show (Instance.mem i)
, show (Instance.dsk i)
, show (Instance.vcpus i)
let verbose = optVerbose opts
ispec = optISpec opts
+ shownodes = optShowNodes opts
- (fixed_nl, il, csf) <- loadExternalData opts
+ (fixed_nl, il, _, csf) <- loadExternalData opts
printKeys $ map (\(a, fn) -> ("SPEC_" ++ a, fn ispec)) specData
printKeys [ ("SPEC_RQN", printf "%d" (optINodes opts)) ]
let offline_names = optOffline opts
all_nodes = Container.elems fixed_nl
all_names = map Node.name all_nodes
- offline_wrong = filter (flip notElem all_names) offline_names
+ offline_wrong = filter (`notElem` all_names) offline_names
offline_indices = map Node.idx $
- filter (\n -> elem (Node.name n) offline_names)
+ filter (\n -> Node.name n `elem` offline_names)
all_nodes
req_nodes = optINodes opts
m_cpu = optMcpu opts
when (length offline_wrong > 0) $ do
hPrintf stderr "Error: Wrong node name(s) set as offline: %s\n"
- (commaJoin offline_wrong)
+ (commaJoin offline_wrong) :: IO ()
exitWith $ ExitFailure 1
when (req_nodes /= 1 && req_nodes /= 2) $ do
- hPrintf stderr "Error: Invalid required nodes (%d)\n" req_nodes
+ hPrintf stderr "Error: Invalid required nodes (%d)\n"
+ req_nodes :: IO ()
exitWith $ ExitFailure 1
- let nm = Container.map (\n -> if elem (Node.idx n) offline_indices
+ let nm = Container.map (\n -> if Node.idx n `elem` offline_indices
then Node.setOffline n True
else n) fixed_nl
nl = Container.map (flip Node.setMdsk m_dsk . flip Node.setMcpu m_cpu)
when (length csf > 0 && verbose > 1) $
hPrintf stderr "Note: Stripping common suffix of '%s' from names\n" csf
- when (optShowNodes opts) $
+ when (isJust shownodes) $
do
hPutStrLn stderr "Initial cluster status:"
- hPutStrLn stderr $ Cluster.printNodes nl
+ hPutStrLn stderr $ Cluster.printNodes nl (fromJust shownodes)
let ini_cv = Cluster.compCV nl
ini_stats = Cluster.totalResources nl
printKeys $ printStats PInitial ini_stats
let bad_nodes = fst $ Cluster.computeBadItems nl il
- when (length bad_nodes > 0) $ do
- -- This is failn1 case, so we print the same final stats and
- -- exit early
- printResults nl num_instances 0 [(FailN1, 1)]
- exitWith ExitSuccess
-
- let reqinst = Instance.create "new" (rspecMem ispec) (rspecDsk ispec)
- (rspecCpu ispec) "ADMIN_down" (-1) (-1)
-
- let result = iterateDepth nl il reqinst req_nodes []
- (ereason, fin_nl, ixes) <- (case result of
- Bad s -> do
- hPrintf stderr "Failure: %s\n" s
- exitWith $ ExitFailure 1
- Ok x -> return x)
+ stop_allocation = length bad_nodes > 0
+ result_noalloc = ([(FailN1, 1)]::FailStats, nl, [])
+
+ -- utility functions
+ let iofspec spx = Instance.create "new" (rspecMem spx) (rspecDsk spx)
+ (rspecCpu spx) "ADMIN_down" [] (-1) (-1)
+ exitifbad val = (case val of
+ Bad s -> do
+ hPrintf stderr "Failure: %s\n" s :: IO ()
+ exitWith $ ExitFailure 1
+ Ok x -> return x)
+
+
+ let reqinst = iofspec ispec
+
+ -- Run the tiered allocation, if enabled
+
+ (case optTieredSpec opts of
+ Nothing -> return ()
+ Just tspec -> do
+ (_, trl_nl, trl_ixes) <-
+ if stop_allocation
+ then return result_noalloc
+ else exitifbad (tieredAlloc nl il (iofspec tspec) req_nodes [])
+ let fin_trl_ixes = reverse trl_ixes
+ ix_byspec = groupBy ((==) `on` Instance.specOf) fin_trl_ixes
+ spec_map = map (\ixs -> (Instance.specOf $ head ixs, length ixs))
+ ix_byspec::[(RSpec, Int)]
+ spec_map' = map (\(spec, cnt) ->
+ printf "%d,%d,%d=%d" (rspecMem spec)
+ (rspecDsk spec) (rspecCpu spec) cnt)
+ spec_map::[String]
+
+ when (verbose > 1) $ do
+ hPutStrLn stderr "Tiered allocation map"
+ hPutStr stderr . unlines . map ((:) ' ' . intercalate " ") $
+ formatTable (map (printInstance trl_nl) fin_trl_ixes)
+ [False, False, False, True, True, True]
+
+ when (isJust shownodes) $ do
+ hPutStrLn stderr ""
+ hPutStrLn stderr "Tiered allocation status:"
+ hPutStrLn stderr $ Cluster.printNodes trl_nl (fromJust shownodes)
+
+ printKeys $ printStats PTiered (Cluster.totalResources trl_nl)
+ printKeys [("TSPEC", intercalate " " spec_map')]
+ printAllocationStats nl trl_nl)
+
+ -- Run the standard (avg-mode) allocation
+
+ (ereason, fin_nl, ixes) <-
+ if stop_allocation
+ then return result_noalloc
+ else exitifbad (iterateDepth nl il reqinst req_nodes [])
+
let allocs = length ixes
fin_ixes = reverse ixes
- sreason = reverse $ sortBy (compare `on` snd) ereason
+ sreason = reverse $ sortBy (comparing snd) ereason
when (verbose > 1) $ do
hPutStrLn stderr "Instance map"
hPutStr stderr . unlines . map ((:) ' ' . intercalate " ") $
formatTable (map (printInstance fin_nl) fin_ixes)
[False, False, False, True, True, True]
- when (optShowNodes opts) $
+ when (isJust shownodes) $
do
hPutStrLn stderr ""
hPutStrLn stderr "Final cluster status:"
- hPutStrLn stderr $ Cluster.printNodes fin_nl
+ hPutStrLn stderr $ Cluster.printNodes fin_nl (fromJust shownodes)
printResults fin_nl num_instances allocs sreason
projects / ganeti-local / blobdiff