1 {-| Implementation of the iallocator interface.
7 Copyright (C) 2009, 2010, 2011 Google Inc.
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.
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.
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
26 module Ganeti.HTools.IAlloc
32 import Data.Maybe (fromMaybe)
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 qualified Ganeti.Constants as C
42 import Ganeti.HTools.Loader
43 import Ganeti.HTools.Utils
44 import Ganeti.HTools.Types
46 -- | Parse the basic specifications of an instance.
48 -- Instances in the cluster instance list and the instance in an
49 -- 'Allocate' request share some common properties, which are read by
51 parseBaseInstance :: String
52 -> [(String, JSValue)]
53 -> Result (String, Instance.Instance)
54 parseBaseInstance n a = do
55 let extract x = tryFromObj ("invalid data for instance '" ++ n ++ "'") a x
56 disk <- extract "disk_space_total"
57 mem <- extract "memory"
58 vcpus <- extract "vcpus"
59 tags <- extract "tags"
60 let running = "running"
61 return (n, Instance.create n mem disk vcpus running tags True 0 0)
63 -- | Parses an instance as found in the cluster instance listg.
64 parseInstance :: NameAssoc -- ^ The node name-to-index association list
65 -> String -- ^ The name of the instance
66 -> [(String, JSValue)] -- ^ The JSON object
67 -> Result (String, Instance.Instance)
68 parseInstance ktn n a = do
69 base <- parseBaseInstance n a
70 nodes <- fromObj a "nodes"
71 pnode <- if null nodes
72 then Bad $ "empty node list for instance " ++ n
73 else readEitherString $ head nodes
74 pidx <- lookupNode ktn n pnode
75 let snodes = tail nodes
76 sidx <- (if null snodes then return Node.noSecondary
77 else readEitherString (head snodes) >>= lookupNode ktn n)
78 return (n, Instance.setBoth (snd base) pidx sidx)
80 -- | Parses a node as found in the cluster node list.
81 parseNode :: NameAssoc -- ^ The group association
82 -> String -- ^ The node's name
83 -> [(String, JSValue)] -- ^ The JSON object
84 -> Result (String, Node.Node)
85 parseNode ktg n a = do
86 let desc = "invalid data for node '" ++ n ++ "'"
87 extract x = tryFromObj desc a x
88 offline <- extract "offline"
89 drained <- extract "drained"
90 guuid <- extract "group"
91 vm_capable <- annotateResult desc $ maybeFromObj a "vm_capable"
92 let vm_capable' = fromMaybe True vm_capable
93 gidx <- lookupGroup ktg n guuid
94 node <- (if offline || drained || not vm_capable'
95 then return $ Node.create n 0 0 0 0 0 0 True gidx
97 mtotal <- extract "total_memory"
98 mnode <- extract "reserved_memory"
99 mfree <- extract "free_memory"
100 dtotal <- extract "total_disk"
101 dfree <- extract "free_disk"
102 ctotal <- extract "total_cpus"
103 return $ Node.create n mtotal mnode mfree
104 dtotal dfree ctotal False gidx)
107 -- | Parses a group as found in the cluster group list.
108 parseGroup :: String -- ^ The group UUID
109 -> [(String, JSValue)] -- ^ The JSON object
110 -> Result (String, Group.Group)
112 let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x
113 name <- extract "name"
114 apol <- extract "alloc_policy"
115 return (u, Group.create name u apol)
117 parseTargetGroups :: [(String, JSValue)] -- ^ The JSON object (request dict)
118 -> Group.List -- ^ The existing groups
120 parseTargetGroups req map_g = do
121 group_uuids <- fromObjWithDefault req "target_groups" []
122 mapM (liftM Group.idx . Container.findByName map_g) group_uuids
124 -- | Top-level parser.
125 parseData :: String -- ^ The JSON message as received from Ganeti
126 -> Result Request -- ^ A (possible valid) request
128 decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
129 let obj = fromJSObject decoded
130 extrObj x = tryFromObj "invalid iallocator message" obj x
132 request <- liftM fromJSObject (extrObj "request")
133 let extrReq x = tryFromObj "invalid request dict" request x
134 -- existing group parsing
135 glist <- liftM fromJSObject (extrObj "nodegroups")
136 gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist
137 let (ktg, gl) = assignIndices gobj
138 -- existing node parsing
139 nlist <- liftM fromJSObject (extrObj "nodes")
140 nobj <- mapM (\(x,y) ->
141 asJSObject y >>= parseNode ktg x . fromJSObject) nlist
142 let (ktn, nl) = assignIndices nobj
143 -- existing instance parsing
144 ilist <- extrObj "instances"
145 let idata = fromJSObject ilist
146 iobj <- mapM (\(x,y) ->
147 asJSObject y >>= parseInstance ktn x . fromJSObject) idata
148 let (kti, il) = assignIndices iobj
150 ctags <- extrObj "cluster_tags"
151 cdata <- mergeData [] [] [] (ClusterData gl nl il ctags)
152 let map_n = cdNodes cdata
153 map_i = cdInstances cdata
154 map_g = cdGroups cdata
155 optype <- extrReq "type"
158 _ | optype == C.iallocatorModeAlloc ->
160 rname <- extrReq "name"
161 req_nodes <- extrReq "required_nodes"
162 inew <- parseBaseInstance rname request
164 return $ Allocate io req_nodes
165 | optype == C.iallocatorModeReloc ->
167 rname <- extrReq "name"
168 ridx <- lookupInstance kti rname
169 req_nodes <- extrReq "required_nodes"
170 ex_nodes <- extrReq "relocate_from"
171 ex_idex <- mapM (Container.findByName map_n) ex_nodes
172 return $ Relocate ridx req_nodes (map Node.idx ex_idex)
173 | optype == C.iallocatorModeMevac ->
175 ex_names <- extrReq "evac_nodes"
176 ex_nodes <- mapM (Container.findByName map_n) ex_names
177 let ex_ndx = map Node.idx ex_nodes
178 return $ Evacuate ex_ndx
179 | optype == C.iallocatorModeMreloc ->
181 rl_names <- extrReq "instances"
182 rl_insts <- mapM (Container.findByName map_i) rl_names
183 let rl_idx = map Instance.idx rl_insts
185 case extrReq "reloc_mode" of
186 Ok s | s == C.iallocatorMrelocKeep -> return KeepGroup
187 | s == C.iallocatorMrelocChange ->
189 tg_groups <- parseTargetGroups request map_g
190 return $ ChangeGroup tg_groups
191 | s == C.iallocatorMrelocAny -> return AnyGroup
192 | otherwise -> Bad $ "Invalid relocate mode " ++ s
194 return $ MultiReloc rl_idx rl_mode
196 | otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
197 return $ Request rqtype cdata
199 -- | Format the result
200 formatRVal :: RqType -> [Node.AllocElement] -> JSValue
201 formatRVal _ [] = JSArray []
203 formatRVal (Evacuate _) elems =
204 let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl)
206 jsols = map (JSArray . map (JSString . toJSString)) sols
210 let (_, _, nodes, _) = head elems
211 nodes' = map Node.name nodes
212 in JSArray $ map (JSString . toJSString) nodes'
214 -- | Formats the response into a valid IAllocator response message.
215 formatResponse :: Bool -- ^ Whether the request was successful
216 -> String -- ^ Information text
217 -> RqType -- ^ Request type
218 -> [Node.AllocElement] -- ^ The resulting allocations
219 -> String -- ^ The JSON-formatted message
220 formatResponse success info rq elems =
222 e_success = ("success", JSBool success)
223 e_info = ("info", JSString . toJSString $ info)
224 e_result = ("result", formatRVal rq elems)
225 in encodeStrict $ makeObj [e_success, e_info, e_result]