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 node <- (if offline || drained
84 then return $ Node.create n 0 0 0 0 0 0 True
86 mtotal <- fromObj "total_memory" a
87 mnode <- fromObj "reserved_memory" a
88 mfree <- fromObj "free_memory" a
89 dtotal <- fromObj "total_disk" a
90 dfree <- fromObj "free_disk" a
91 ctotal <- fromObj "total_cpus" a
92 return $ Node.create n mtotal mnode mfree
93 dtotal dfree ctotal False)
96 -- | Top-level parser.
97 parseData :: String -- ^ The JSON message as received from Ganeti
98 -> Result Request -- ^ A (possible valid) request
100 decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
101 let obj = fromJSObject decoded
103 request <- liftM fromJSObject (fromObj "request" obj)
104 -- existing node parsing
105 nlist <- liftM fromJSObject (fromObj "nodes" obj)
106 nobj <- mapM (\(x,y) -> asJSObject y >>= parseNode x . fromJSObject) nlist
107 let (ktn, nl) = assignIndices nobj
108 -- existing instance parsing
109 ilist <- fromObj "instances" obj
110 let idata = fromJSObject ilist
111 iobj <- mapM (\(x,y) ->
112 asJSObject y >>= parseInstance ktn x . fromJSObject) idata
113 let (kti, il) = assignIndices iobj
115 ctags <- fromObj "cluster_tags" obj
116 (map_n, map_i, ptags) <- mergeData [] [] [] (nl, il, ctags)
117 optype <- fromObj "type" request
122 rname <- fromObj "name" request
123 req_nodes <- fromObj "required_nodes" request
124 inew <- parseBaseInstance rname request
126 return $ Allocate io req_nodes
129 rname <- fromObj "name" request
130 ridx <- lookupInstance kti rname
131 req_nodes <- fromObj "required_nodes" request
132 ex_nodes <- fromObj "relocate_from" request
133 ex_idex <- mapM (Container.findByName map_n) ex_nodes
134 return $ Relocate ridx req_nodes (map Node.idx ex_idex)
137 ex_names <- fromObj "evac_nodes" request
138 ex_nodes <- mapM (Container.findByName map_n) ex_names
139 let ex_ndx = map Node.idx ex_nodes
140 return $ Evacuate ex_ndx
141 other -> fail ("Invalid request type '" ++ other ++ "'")
142 return $ Request rqtype map_n map_i ptags
144 -- | Format the result
145 formatRVal :: RqType -> [Node.AllocElement] -> JSValue
146 formatRVal _ [] = JSArray []
148 formatRVal (Evacuate _) elems =
149 let sols = map (\(_, inst, nl) -> Instance.name inst : map Node.name nl)
151 jsols = map (JSArray . map (JSString . toJSString)) sols
155 let (_, _, nodes) = head elems
156 nodes' = map Node.name nodes
157 in JSArray $ map (JSString . toJSString) nodes'
159 -- | Formats the response into a valid IAllocator response message.
160 formatResponse :: Bool -- ^ Whether the request was successful
161 -> String -- ^ Information text
162 -> RqType -- ^ Request type
163 -> [Node.AllocElement] -- ^ The resulting allocations
164 -> String -- ^ The JSON-formatted message
165 formatResponse success info rq elems =
167 e_success = ("success", JSBool success)
168 e_info = ("info", JSString . toJSString $ info)
169 e_nodes = ("nodes", formatRVal rq elems)
170 in encodeStrict $ makeObj [e_success, e_info, e_nodes]