Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
itminedu
snf-ganeti
Commits
ed41c179
Commit
ed41c179
authored
May 24, 2009
by
Iustin Pop
Browse files
Start implementing the hail functionality
This patch implements a very stupid (and broken) version of hail ‘allocate’.
parent
e3a684c5
Changes
4
Hide whitespace changes
Inline
Side-by-side
Ganeti/HTools/IAlloc.hs
View file @
ed41c179
...
...
@@ -6,6 +6,8 @@ module Ganeti.HTools.IAlloc
(
parseData
,
formatResponse
,
RqType
(
..
)
,
Request
(
..
)
)
where
import
Data.Either
()
...
...
@@ -22,8 +24,8 @@ import Ganeti.HTools.Utils
import
Ganeti.HTools.Types
data
RqType
=
Allocate
String
Instance
.
Instance
|
Relocate
Int
=
Allocate
Instance
.
Instance
Int
|
Relocate
Int
Int
[
Int
]
deriving
(
Show
)
data
Request
=
Request
RqType
NodeList
InstanceList
String
...
...
@@ -88,20 +90,24 @@ parseData body = do
let
idata
=
fromJSObject
ilist
iobj
<-
(
mapM
(
\
(
x
,
y
)
->
asJSObject
y
>>=
parseInstance
ktn
x
))
idata
let
(
kti
,
il
)
=
assignIndices
iobj
(
map_n
,
map_i
,
csf
)
<-
mergeData
(
nl
,
il
)
req_nodes
<-
fromObj
"required_nodes"
request
optype
<-
fromObj
"type"
request
rqtype
<-
case
optype
of
"allocate"
->
do
inew
<-
parseBaseInstance
rname
request
let
(
iname
,
io
)
=
inew
return
$
Allocate
i
name
io
let
io
=
snd
inew
return
$
Allocate
i
o
req_nodes
"relocate"
->
do
ridx
<-
lookupNode
kti
rname
rname
return
$
Relocate
ridx
ex_nodes
<-
fromObj
"relocate_from"
request
let
ex_nodes'
=
map
(
stripSuffix
$
length
csf
)
ex_nodes
ex_idex
<-
mapM
(
findByName
map_n
)
ex_nodes'
return
$
Relocate
ridx
req_nodes
ex_idex
other
->
fail
$
(
"Invalid request type '"
++
other
++
"'"
)
(
map_n
,
map_i
,
csf
)
<-
mergeData
(
nl
,
il
)
return
$
Request
rqtype
map_n
map_i
csf
formatResponse
::
Bool
->
String
->
[
String
]
->
String
...
...
Ganeti/HTools/Loader.hs
View file @
ed41c179
...
...
@@ -9,6 +9,7 @@ module Ganeti.HTools.Loader
,
checkData
,
assignIndices
,
lookupNode
,
stripSuffix
)
where
import
Data.List
...
...
Ganeti/HTools/Types.hs
View file @
ed41c179
...
...
@@ -68,3 +68,17 @@ cNameOf c k = name $ Container.find k c
-- | Compute the maximum name length in an Element Container
cMaxNamelen
::
(
Element
a
)
=>
Container
.
Container
a
->
Int
cMaxNamelen
=
maximum
.
map
(
length
.
name
)
.
Container
.
elems
-- | Find an element by name in a Container; this is a very slow function
findByName
::
(
Element
a
,
Monad
m
)
=>
Container
.
Container
a
->
String
->
m
Container
.
Key
findByName
c
n
=
let
all_elems
=
Container
.
elems
c
result
=
filter
((
==
n
)
.
name
)
all_elems
nems
=
length
result
in
if
nems
/=
1
then
fail
$
"Wrong number of elems ("
++
(
show
nems
)
++
") found with name "
++
n
else
return
$
idx
$
head
result
hail.hs
View file @
ed41c179
...
...
@@ -18,6 +18,7 @@ import Text.Printf (printf)
import
qualified
Ganeti.HTools.Container
as
Container
import
qualified
Ganeti.HTools.Cluster
as
Cluster
import
qualified
Ganeti.HTools.Node
as
Node
import
qualified
Ganeti.HTools.Instance
as
Instance
import
qualified
Ganeti.HTools.CLI
as
CLI
import
Ganeti.HTools.IAlloc
import
Ganeti.HTools.Utils
...
...
@@ -112,11 +113,25 @@ options =
"show help"
]
-- | Formats the solution for the oneline display
formatOneline
::
Double
->
Int
->
Double
->
String
formatOneline
ini_cv
plc_len
fin_cv
=
printf
"%.8f %d %.8f %8.3f"
ini_cv
plc_len
fin_cv
(
if
fin_cv
==
0
then
1
else
(
ini_cv
/
fin_cv
))
-- | Try to allocate an instance on the cluster
tryAlloc
::
NodeList
->
InstanceList
->
Instance
.
Instance
->
Int
->
Result
[
Node
.
Node
]
tryAlloc
nl
il
xi
_
=
Bad
"alloc not implemented"
-- | Try to allocate an instance on the cluster
tryReloc
::
NodeList
->
InstanceList
->
Int
->
Int
->
[
Int
]
->
Result
[
Node
.
Node
]
tryReloc
nl
il
xid
reqn
ex_idx
=
let
all_nodes
=
Container
.
elems
nl
valid_nodes
=
filter
(
not
.
flip
elem
ex_idx
.
idx
)
all_nodes
in
Ok
(
take
reqn
valid_nodes
)
-- | Main function.
main
::
IO
()
...
...
@@ -138,127 +153,13 @@ main = do
exitWith
$
ExitFailure
1
Ok
rq
->
return
rq
putStrLn
$
show
request
exitWith
ExitSuccess
{-
(loaded_nl, il, csf, ktn, kti) <- liftM2 Cluster.loadData node_data inst_data
let (fix_msgs, fixed_nl) = Cluster.checkData loaded_nl il ktn kti
unless (null fix_msgs || verbose == 0) $ do
putStrLn "Warning: cluster has inconsistent data:"
putStrLn . unlines . map (\s -> printf " - %s" s) $ fix_msgs
let offline_names = optOffline opts
all_names = snd . unzip $ ktn
offline_wrong = filter (\n -> not $ elem n all_names) offline_names
offline_indices = fst . unzip .
filter (\(_, n) -> elem n offline_names) $ ktn
when (length offline_wrong > 0) $ do
printf "Wrong node name(s) set as offline: %s\n"
(commaJoin offline_wrong)
exitWith $ ExitFailure 1
let nl = Container.map (\n -> if elem (Node.idx n) offline_indices
then Node.setOffline n True
else n) fixed_nl
when (Container.size il == 0) $ do
(if oneline then
putStrLn $ formatOneline 0 0 0
else
printf "Cluster is empty, exiting.\n")
exitWith ExitSuccess
unless oneline $ printf "Loaded %d nodes, %d instances\n"
(Container.size nl)
(Container.size il)
when (length csf > 0 && not oneline && verbose > 1) $ do
printf "Note: Stripping common suffix of '%s' from names\n" csf
let (bad_nodes, bad_instances) = Cluster.computeBadItems nl il
unless (oneline || verbose == 0) $ printf
"Initial check done: %d bad nodes, %d bad instances.\n"
(length bad_nodes) (length bad_instances)
when (length bad_nodes > 0) $ do
putStrLn "Cluster is not N+1 happy, continuing but no guarantee \
\that the cluster will end N+1 happy."
when (optShowNodes opts) $
do
putStrLn "Initial cluster status:"
putStrLn $ Cluster.printNodes ktn nl
let ini_cv = Cluster.compCV nl
ini_tbl = Cluster.Table nl il ini_cv []
min_cv = optMinScore opts
when (ini_cv < min_cv) $ do
(if oneline then
putStrLn $ formatOneline ini_cv 0 ini_cv
else printf "Cluster is already well balanced (initial score %.6g,\n\
\minimum score %.6g).\nNothing to do, exiting\n"
ini_cv min_cv)
exitWith ExitSuccess
unless oneline (if verbose > 2 then
printf "Initial coefficients: overall %.8f, %s\n"
ini_cv (Cluster.printStats nl)
else
printf "Initial score: %.8f\n" ini_cv)
unless oneline $ putStrLn "Trying to minimize the CV..."
let mlen_fn = maximum . (map length) . snd . unzip
imlen = mlen_fn kti
nmlen = mlen_fn ktn
(fin_tbl, cmd_strs) <- iterateDepth ini_tbl (optMaxLength opts)
ktn kti nmlen imlen [] oneline min_cv
let (Cluster.Table fin_nl _ fin_cv fin_plc) = fin_tbl
ord_plc = reverse fin_plc
sol_msg = if null fin_plc
then printf "No solution found\n"
else (if verbose > 2
then printf "Final coefficients: overall %.8f, %s\n"
fin_cv (Cluster.printStats fin_nl)
else printf "Cluster score improved from %.8f to %.8f\n"
ini_cv fin_cv
)
unless oneline $ putStr sol_msg
unless (oneline || verbose == 0) $
printf "Solution length=%d\n" (length ord_plc)
let cmd_data = Cluster.formatCmds . reverse $ cmd_strs
when (isJust $ optShowCmds opts) $
do
let out_path = fromJust $ optShowCmds opts
putStrLn ""
(if out_path == "-" then
printf "Commands to run to reach the above solution:\n%s"
(unlines . map (" " ++) .
filter (/= "check") .
lines $ cmd_data)
else do
writeFile out_path (CLI.shTemplate ++ cmd_data)
printf "The commands have been written to file '%s'\n" out_path)
when (optShowNodes opts) $
do
let (orig_mem, orig_disk) = Cluster.totalResources nl
(final_mem, final_disk) = Cluster.totalResources fin_nl
putStrLn ""
putStrLn "Final cluster status:"
putStrLn $ Cluster.printNodes ktn fin_nl
when (verbose > 3) $
do
printf "Original: mem=%d disk=%d\n" orig_mem orig_disk
printf "Final: mem=%d disk=%d\n" final_mem final_disk
when oneline $
putStrLn $ formatOneline ini_cv (length ord_plc) fin_cv
-}
let
Request
rqtype
nl
il
csf
=
request
new_nodes
=
case
rqtype
of
Allocate
xi
reqn
->
tryAlloc
nl
il
xi
reqn
Relocate
idx
reqn
exnodes
->
tryReloc
nl
il
idx
reqn
exnodes
let
(
ok
,
info
,
rn
)
=
case
new_nodes
of
Ok
sn
->
(
True
,
"Request successfull"
,
map
name
sn
)
Bad
s
->
(
False
,
"Request failed: "
++
s
,
[]
)
resp
=
formatResponse
ok
info
rn
putStrLn
resp
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment