1 {-| Implementation of the iallocator interface.
7 Copyright (C) 2009 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
33 import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
34 makeObj, encodeStrict, decodeStrict,
35 fromJSObject, toJSString)
36 import qualified Ganeti.HTools.Container as Container
37 import qualified Ganeti.HTools.Node as Node
38 import qualified Ganeti.HTools.Instance as Instance
39 import Ganeti.HTools.Loader
40 import Ganeti.HTools.Utils
41 import Ganeti.HTools.Types
43 -- | Parse the basic specifications of an instance.
45 -- Instances in the cluster instance list and the instance in an
46 -- 'Allocate' request share some common properties, which are read by
48 parseBaseInstance :: String
49 -> [(String, JSValue)]
50 -> Result (String, Instance.Instance)
51 parseBaseInstance n a = do
52 disk <- fromObj "disk_space_total" a
53 mem <- fromObj "memory" a
54 vcpus <- fromObj "vcpus" a
55 tags <- fromObj "tags" a
56 let running = "running"
57 return (n, Instance.create n mem disk vcpus running tags 0 0)
59 -- | Parses an instance as found in the cluster instance listg.
60 parseInstance :: NameAssoc -- ^ The node name-to-index association list
61 -> String -- ^ The name of the instance
62 -> [(String, JSValue)] -- ^ The JSON object
63 -> Result (String, Instance.Instance)
64 parseInstance ktn n a = do
65 base <- parseBaseInstance n a
66 nodes <- fromObj "nodes" a
67 pnode <- if null nodes
68 then Bad $ "empty node list for instance " ++ n
69 else readEitherString $ head nodes
70 pidx <- lookupNode ktn n pnode
71 let snodes = tail nodes
72 sidx <- (if null snodes then return Node.noSecondary
73 else readEitherString (head snodes) >>= lookupNode ktn n)
74 return (n, Instance.setBoth (snd base) pidx sidx)
76 -- | Parses a node as found in the cluster node list.
77 parseNode :: String -- ^ The node's name
78 -> [(String, JSValue)] -- ^ The JSON object
79 -> Result (String, Node.Node)
81 offline <- fromObj "offline" a
82 drained <- fromObj "drained" a
83 guuid <- fromObj "group" a
84 node <- (if offline || drained
85 then return $ Node.create n 0 0 0 0 0 0 True guuid
87 mtotal <- fromObj "total_memory" a
88 mnode <- fromObj "reserved_memory" a
89 mfree <- fromObj "free_memory" a
90 dtotal <- fromObj "total_disk" a
91 dfree <- fromObj "free_disk" a
92 ctotal <- fromObj "total_cpus" a
93 return $ Node.create n mtotal mnode mfree
94 dtotal dfree ctotal False guuid)
97 -- | Top-level parser.
98 parseData :: String -- ^ The JSON message as received from Ganeti
99 -> Result Request -- ^ A (possible valid) request
101 decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
102 let obj = fromJSObject decoded
104 request <- liftM fromJSObject (fromObj "request" obj)
105 -- existing node parsing
106 nlist <- liftM fromJSObject (fromObj "nodes" obj)
107 nobj <- mapM (\(x,y) -> asJSObject y >>= parseNode x . fromJSObject) nlist
108 let (ktn, nl) = assignIndices nobj
109 -- existing instance parsing
110 ilist <- fromObj "instances" obj
111 let idata = fromJSObject ilist
112 iobj <- mapM (\(x,y) ->
113 asJSObject y >>= parseInstance ktn x . fromJSObject) idata
114 let (kti, il) = assignIndices iobj
116 ctags <- fromObj "cluster_tags" obj
117 (map_n, map_i, ptags) <- mergeData [] [] [] (nl, il, ctags)
118 optype <- fromObj "type" request
123 rname <- fromObj "name" request
124 req_nodes <- fromObj "required_nodes" request
125 inew <- parseBaseInstance rname request
127 return $ Allocate io req_nodes
130 rname <- fromObj "name" request
131 ridx <- lookupInstance kti rname
132 req_nodes <- fromObj "required_nodes" request
133 ex_nodes <- fromObj "relocate_from" request
134 ex_idex <- mapM (Container.findByName map_n) ex_nodes
135 return $ Relocate ridx req_nodes (map Node.idx ex_idex)
138 ex_names <- fromObj "evac_nodes" request
139 ex_nodes <- mapM (Container.findByName map_n) ex_names
140 let ex_ndx = map Node.idx ex_nodes
141 return $ Evacuate ex_ndx
142 other -> fail ("Invalid request type '" ++ other ++ "'")
143 return $ Request rqtype map_n map_i ptags
145 -- | Format the result
146 formatRVal :: RqType -> [Node.AllocElement] -> JSValue
147 formatRVal _ [] = JSArray []
149 formatRVal (Evacuate _) elems =
150 let sols = map (\(_, inst, nl) -> Instance.name inst : map Node.name nl)
152 jsols = map (JSArray . map (JSString . toJSString)) sols
156 let (_, _, nodes) = head elems
157 nodes' = map Node.name nodes
158 in JSArray $ map (JSString . toJSString) nodes'
160 -- | Formats the response into a valid IAllocator response message.
161 formatResponse :: Bool -- ^ Whether the request was successful
162 -> String -- ^ Information text
163 -> RqType -- ^ Request type
164 -> [Node.AllocElement] -- ^ The resulting allocations
165 -> String -- ^ The JSON-formatted message
166 formatResponse success info rq elems =
168 e_success = ("success", JSBool success)
169 e_info = ("info", JSString . toJSString $ info)
170 e_nodes = ("nodes", formatRVal rq elems)
171 in encodeStrict $ makeObj [e_success, e_info, e_nodes]