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
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 let running = "running"
56 return (n, Instance.create n mem disk vcpus running 0 0)
58 -- | Parses an instance as found in the cluster instance list.
59 parseInstance :: NameAssoc -- ^ The node name-to-index association list
60 -> String -- ^ The name of the instance
61 -> JSObject JSValue -- ^ The JSON object
62 -> Result (String, Instance.Instance)
63 parseInstance ktn n a = do
64 base <- parseBaseInstance n a
65 nodes <- fromObj "nodes" a
66 pnode <- readEitherString $ head nodes
67 pidx <- lookupNode ktn n pnode
68 let snodes = tail nodes
69 sidx <- (if null snodes then return Node.noSecondary
70 else readEitherString (head snodes) >>= lookupNode ktn n)
71 return (n, Instance.setBoth (snd base) pidx sidx)
73 -- | Parses a node as found in the cluster node list.
74 parseNode :: String -- ^ The node's name
75 -> JSObject JSValue -- ^ The JSON object
76 -> Result (String, Node.Node)
79 offline <- fromObj "offline" a
80 drained <- fromObj "drained" a
81 node <- (if offline || drained
82 then return $ Node.create name 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
101 request <- fromObj "request" obj
102 rname <- fromObj "name" request
103 -- existing node parsing
104 nlist <- fromObj "nodes" obj
105 let ndata = fromJSObject nlist
106 nobj <- mapM (\(x,y) -> asJSObject y >>= parseNode x) ndata
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) -> asJSObject y >>= parseInstance ktn x) idata
112 let (kti, il) = assignIndices iobj
113 (map_n, map_i, csf) <- mergeData [] (nl, il)
114 req_nodes <- fromObj "required_nodes" request
115 optype <- fromObj "type" request
120 inew <- parseBaseInstance rname request
122 return $ Allocate io req_nodes
125 ridx <- lookupInstance kti rname
126 ex_nodes <- fromObj "relocate_from" request
127 let ex_nodes' = map (stripSuffix $ length csf) ex_nodes
128 ex_idex <- mapM (Container.findByName map_n) ex_nodes'
129 return $ Relocate ridx req_nodes (map Node.idx ex_idex)
130 other -> fail ("Invalid request type '" ++ other ++ "'")
131 return $ Request rqtype map_n map_i csf
133 -- | Formats the response into a valid IAllocator response message.
134 formatResponse :: Bool -- ^ Whether the request was successful
135 -> String -- ^ Information text
136 -> [String] -- ^ The list of chosen nodes
137 -> String -- ^ The JSON-formatted message
138 formatResponse success info nodes =
140 e_success = ("success", JSBool success)
141 e_info = ("info", JSString . toJSString $ info)
142 e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
143 in encodeStrict $ makeObj [e_success, e_info, e_nodes]