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 <- readEitherString $ head nodes
68 pidx <- lookupNode ktn n pnode
69 let snodes = tail nodes
70 sidx <- (if null snodes then return Node.noSecondary
71 else readEitherString (head snodes) >>= lookupNode ktn n)
72 return (n, Instance.setBoth (snd base) pidx sidx)
74 -- | Parses a node as found in the cluster node list.
75 parseNode :: String -- ^ The node's name
76 -> [(String, JSValue)] -- ^ The JSON object
77 -> Result (String, Node.Node)
79 offline <- fromObj "offline" a
80 drained <- fromObj "drained" a
81 node <- (if offline || drained
82 then return $ Node.create n 0 0 0 0 0 0 True
84 mtotal <- fromObj "total_memory" a
85 mnode <- fromObj "reserved_memory" a
86 mfree <- fromObj "free_memory" a
87 dtotal <- fromObj "total_disk" a
88 dfree <- fromObj "free_disk" a
89 ctotal <- fromObj "total_cpus" a
90 return $ Node.create n mtotal mnode mfree
91 dtotal dfree ctotal False)
94 -- | Top-level parser.
95 parseData :: String -- ^ The JSON message as received from Ganeti
96 -> Result Request -- ^ A (possible valid) request
98 decoded <- fromJResult $ decodeStrict body
99 let obj = fromJSObject decoded
101 request <- liftM fromJSObject (fromObj "request" obj)
102 -- existing node parsing
103 nlist <- liftM fromJSObject (fromObj "nodes" obj)
104 nobj <- mapM (\(x,y) -> asJSObject y >>= parseNode x . fromJSObject) nlist
105 let (ktn, nl) = assignIndices nobj
106 -- existing instance parsing
107 ilist <- fromObj "instances" obj
108 let idata = fromJSObject ilist
109 iobj <- mapM (\(x,y) ->
110 asJSObject y >>= parseInstance ktn x . fromJSObject) idata
111 let (kti, il) = assignIndices iobj
113 ctags <- fromObj "cluster_tags" obj
114 (map_n, map_i, ptags, csf) <- mergeData [] [] [] (nl, il, ctags)
115 optype <- fromObj "type" request
120 rname <- fromObj "name" request
121 req_nodes <- fromObj "required_nodes" request
122 inew <- parseBaseInstance rname request
124 return $ Allocate io req_nodes
127 rname <- fromObj "name" request
128 ridx <- lookupInstance kti rname
129 req_nodes <- fromObj "required_nodes" request
130 ex_nodes <- fromObj "relocate_from" request
131 let ex_nodes' = map (stripSuffix $ length csf) ex_nodes
132 ex_idex <- mapM (Container.findByName map_n) ex_nodes'
133 return $ Relocate ridx req_nodes (map Node.idx ex_idex)
136 ex_names <- fromObj "evac_nodes" request
137 ex_nodes <- mapM (Container.findByName map_n) ex_names
138 let ex_ndx = map Node.idx ex_nodes
139 return $ Evacuate ex_ndx
140 other -> fail ("Invalid request type '" ++ other ++ "'")
141 return $ Request rqtype map_n map_i ptags csf
143 formatRVal :: String -> RqType
144 -> [Node.AllocElement] -> JSValue
145 formatRVal csf (Evacuate _) elems =
146 let sols = map (\(_, inst, nl) ->
147 let names = Instance.name inst : map Node.name nl
148 in map (++ csf) names) elems
149 jsols = map (JSArray . map (JSString . toJSString)) sols
152 formatRVal csf _ elems =
153 let (_, _, nodes) = head elems
154 nodes' = map ((++ csf) . Node.name) nodes
155 in JSArray $ map (JSString . toJSString) nodes'
158 -- | Formats the response into a valid IAllocator response message.
159 formatResponse :: Bool -- ^ Whether the request was successful
160 -> String -- ^ Information text
161 -> String -- ^ Suffix for nodes/instances
162 -> RqType -- ^ Request type
163 -> [Node.AllocElement] -- ^ The resulting allocations
164 -> String -- ^ The JSON-formatted message
165 formatResponse success info csf rq elems =
167 e_success = ("success", JSBool success)
168 e_info = ("info", JSString . toJSString $ info)
169 e_nodes = ("nodes", formatRVal csf rq elems)
170 in encodeStrict $ makeObj [e_success, e_info, e_nodes]