root / htools / Ganeti / HTools / IAlloc.hs @ c352b0a9
History | View | Annotate | Download (7.6 kB)
1 |
{-| Implementation of the iallocator interface. |
---|---|
2 |
|
3 |
-} |
4 |
|
5 |
{- |
6 |
|
7 |
Copyright (C) 2009, 2010, 2011 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.IAlloc |
27 |
( parseData |
28 |
, formatResponse |
29 |
) where |
30 |
|
31 |
import Data.Either () |
32 |
import Data.Maybe (fromMaybe) |
33 |
import Control.Monad |
34 |
import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray), |
35 |
makeObj, encodeStrict, decodeStrict, |
36 |
fromJSObject, toJSString) |
37 |
import qualified Ganeti.HTools.Container as Container |
38 |
import qualified Ganeti.HTools.Group as Group |
39 |
import qualified Ganeti.HTools.Node as Node |
40 |
import qualified Ganeti.HTools.Instance as Instance |
41 |
import Ganeti.HTools.Loader |
42 |
import Ganeti.HTools.Utils |
43 |
import Ganeti.HTools.Types |
44 |
|
45 |
-- | Parse the basic specifications of an instance. |
46 |
-- |
47 |
-- Instances in the cluster instance list and the instance in an |
48 |
-- 'Allocate' request share some common properties, which are read by |
49 |
-- this function. |
50 |
parseBaseInstance :: String |
51 |
-> [(String, JSValue)] |
52 |
-> Result (String, Instance.Instance) |
53 |
parseBaseInstance n a = do |
54 |
let extract x = tryFromObj ("invalid data for instance '" ++ n ++ "'") a x |
55 |
disk <- extract "disk_space_total" |
56 |
mem <- extract "memory" |
57 |
vcpus <- extract "vcpus" |
58 |
tags <- extract "tags" |
59 |
let running = "running" |
60 |
return (n, Instance.create n mem disk vcpus running tags True 0 0) |
61 |
|
62 |
-- | Parses an instance as found in the cluster instance listg. |
63 |
parseInstance :: NameAssoc -- ^ The node name-to-index association list |
64 |
-> String -- ^ The name of the instance |
65 |
-> [(String, JSValue)] -- ^ The JSON object |
66 |
-> Result (String, Instance.Instance) |
67 |
parseInstance ktn n a = do |
68 |
base <- parseBaseInstance n a |
69 |
nodes <- fromObj a "nodes" |
70 |
pnode <- if null nodes |
71 |
then Bad $ "empty node list for instance " ++ n |
72 |
else readEitherString $ head nodes |
73 |
pidx <- lookupNode ktn n pnode |
74 |
let snodes = tail nodes |
75 |
sidx <- (if null snodes then return Node.noSecondary |
76 |
else readEitherString (head snodes) >>= lookupNode ktn n) |
77 |
return (n, Instance.setBoth (snd base) pidx sidx) |
78 |
|
79 |
-- | Parses a node as found in the cluster node list. |
80 |
parseNode :: NameAssoc -- ^ The group association |
81 |
-> String -- ^ The node's name |
82 |
-> [(String, JSValue)] -- ^ The JSON object |
83 |
-> Result (String, Node.Node) |
84 |
parseNode ktg n a = do |
85 |
let desc = "invalid data for node '" ++ n ++ "'" |
86 |
extract x = tryFromObj desc a x |
87 |
offline <- extract "offline" |
88 |
drained <- extract "drained" |
89 |
guuid <- extract "group" |
90 |
vm_capable <- annotateResult desc $ maybeFromObj a "vm_capable" |
91 |
let vm_capable' = fromMaybe True vm_capable |
92 |
gidx <- lookupGroup ktg n guuid |
93 |
node <- (if offline || drained || not vm_capable' |
94 |
then return $ Node.create n 0 0 0 0 0 0 True gidx |
95 |
else do |
96 |
mtotal <- extract "total_memory" |
97 |
mnode <- extract "reserved_memory" |
98 |
mfree <- extract "free_memory" |
99 |
dtotal <- extract "total_disk" |
100 |
dfree <- extract "free_disk" |
101 |
ctotal <- extract "total_cpus" |
102 |
return $ Node.create n mtotal mnode mfree |
103 |
dtotal dfree ctotal False gidx) |
104 |
return (n, node) |
105 |
|
106 |
-- | Parses a group as found in the cluster group list. |
107 |
parseGroup :: String -- ^ The group UUID |
108 |
-> [(String, JSValue)] -- ^ The JSON object |
109 |
-> Result (String, Group.Group) |
110 |
parseGroup u a = do |
111 |
let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x |
112 |
name <- extract "name" |
113 |
apol <- extract "alloc_policy" |
114 |
return (u, Group.create name u apol) |
115 |
|
116 |
-- | Top-level parser. |
117 |
parseData :: String -- ^ The JSON message as received from Ganeti |
118 |
-> Result Request -- ^ A (possible valid) request |
119 |
parseData body = do |
120 |
decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body) |
121 |
let obj = fromJSObject decoded |
122 |
extrObj x = tryFromObj "invalid iallocator message" obj x |
123 |
-- request parser |
124 |
request <- liftM fromJSObject (extrObj "request") |
125 |
let extrReq x = tryFromObj "invalid request dict" request x |
126 |
-- existing group parsing |
127 |
glist <- liftM fromJSObject (extrObj "nodegroups") |
128 |
gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist |
129 |
let (ktg, gl) = assignIndices gobj |
130 |
-- existing node parsing |
131 |
nlist <- liftM fromJSObject (extrObj "nodes") |
132 |
nobj <- mapM (\(x,y) -> |
133 |
asJSObject y >>= parseNode ktg x . fromJSObject) nlist |
134 |
let (ktn, nl) = assignIndices nobj |
135 |
-- existing instance parsing |
136 |
ilist <- extrObj "instances" |
137 |
let idata = fromJSObject ilist |
138 |
iobj <- mapM (\(x,y) -> |
139 |
asJSObject y >>= parseInstance ktn x . fromJSObject) idata |
140 |
let (kti, il) = assignIndices iobj |
141 |
-- cluster tags |
142 |
ctags <- extrObj "cluster_tags" |
143 |
cdata <- mergeData [] [] [] (ClusterData gl nl il ctags) |
144 |
let map_n = cdNodes cdata |
145 |
optype <- extrReq "type" |
146 |
rqtype <- |
147 |
case optype of |
148 |
"allocate" -> |
149 |
do |
150 |
rname <- extrReq "name" |
151 |
req_nodes <- extrReq "required_nodes" |
152 |
inew <- parseBaseInstance rname request |
153 |
let io = snd inew |
154 |
return $ Allocate io req_nodes |
155 |
"relocate" -> |
156 |
do |
157 |
rname <- extrReq "name" |
158 |
ridx <- lookupInstance kti rname |
159 |
req_nodes <- extrReq "required_nodes" |
160 |
ex_nodes <- extrReq "relocate_from" |
161 |
ex_idex <- mapM (Container.findByName map_n) ex_nodes |
162 |
return $ Relocate ridx req_nodes (map Node.idx ex_idex) |
163 |
"multi-evacuate" -> |
164 |
do |
165 |
ex_names <- extrReq "evac_nodes" |
166 |
ex_nodes <- mapM (Container.findByName map_n) ex_names |
167 |
let ex_ndx = map Node.idx ex_nodes |
168 |
return $ Evacuate ex_ndx |
169 |
other -> fail ("Invalid request type '" ++ other ++ "'") |
170 |
return $ Request rqtype cdata |
171 |
|
172 |
-- | Format the result |
173 |
formatRVal :: RqType -> [Node.AllocElement] -> JSValue |
174 |
formatRVal _ [] = JSArray [] |
175 |
|
176 |
formatRVal (Evacuate _) elems = |
177 |
let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl) |
178 |
elems |
179 |
jsols = map (JSArray . map (JSString . toJSString)) sols |
180 |
in JSArray jsols |
181 |
|
182 |
formatRVal _ elems = |
183 |
let (_, _, nodes, _) = head elems |
184 |
nodes' = map Node.name nodes |
185 |
in JSArray $ map (JSString . toJSString) nodes' |
186 |
|
187 |
-- | Formats the response into a valid IAllocator response message. |
188 |
formatResponse :: Bool -- ^ Whether the request was successful |
189 |
-> String -- ^ Information text |
190 |
-> RqType -- ^ Request type |
191 |
-> [Node.AllocElement] -- ^ The resulting allocations |
192 |
-> String -- ^ The JSON-formatted message |
193 |
formatResponse success info rq elems = |
194 |
let |
195 |
e_success = ("success", JSBool success) |
196 |
e_info = ("info", JSString . toJSString $ info) |
197 |
e_nodes = ("nodes", formatRVal rq elems) |
198 |
in encodeStrict $ makeObj [e_success, e_info, e_nodes] |