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 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 listg.
59 parseInstance :: NameAssoc -- ^ The node name-to-index association list
60 -> String -- ^ The name of the instance
61 -> [(String, 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 -> [(String, JSValue)] -- ^ The JSON object
76 -> Result (String, Node.Node)
78 offline <- fromObj "offline" a
79 drained <- fromObj "drained" a
80 node <- (if offline || drained
81 then return $ Node.create n 0 0 0 0 0 0 True
83 mtotal <- fromObj "total_memory" a
84 mnode <- fromObj "reserved_memory" a
85 mfree <- fromObj "free_memory" a
86 dtotal <- fromObj "total_disk" a
87 dfree <- fromObj "free_disk" a
88 ctotal <- fromObj "total_cpus" a
89 return $ Node.create n mtotal mnode mfree
90 dtotal dfree ctotal False)
93 -- | Top-level parser.
94 parseData :: String -- ^ The JSON message as received from Ganeti
95 -> Result Request -- ^ A (possible valid) request
97 decoded <- fromJResult $ decodeStrict body
98 let obj = fromJSObject decoded
100 request <- liftM fromJSObject (fromObj "request" obj)
101 rname <- fromObj "name" request
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
112 (map_n, map_i, csf) <- mergeData [] (nl, il)
113 req_nodes <- fromObj "required_nodes" request
114 optype <- fromObj "type" request
119 inew <- parseBaseInstance rname request
121 return $ Allocate io req_nodes
124 ridx <- lookupInstance kti rname
125 ex_nodes <- fromObj "relocate_from" request
126 let ex_nodes' = map (stripSuffix $ length csf) ex_nodes
127 ex_idex <- mapM (Container.findByName map_n) ex_nodes'
128 return $ Relocate ridx req_nodes (map Node.idx ex_idex)
129 other -> fail ("Invalid request type '" ++ other ++ "'")
130 return $ Request rqtype map_n map_i csf
132 -- | Formats the response into a valid IAllocator response message.
133 formatResponse :: Bool -- ^ Whether the request was successful
134 -> String -- ^ Information text
135 -> [String] -- ^ The list of chosen nodes
136 -> String -- ^ The JSON-formatted message
137 formatResponse success info nodes =
139 e_success = ("success", JSBool success)
140 e_info = ("info", JSString . toJSString $ info)
141 e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
142 in encodeStrict $ makeObj [e_success, e_info, e_nodes]