1 {-| Implementation of the iallocator interface.
5 module Ganeti.HTools.IAlloc
12 import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
13 makeObj, encodeStrict, decodeStrict,
14 fromJSObject, toJSString)
15 import qualified Ganeti.HTools.Container as Container
16 import qualified Ganeti.HTools.Node as Node
17 import qualified Ganeti.HTools.Instance as Instance
18 import Ganeti.HTools.Loader
19 import Ganeti.HTools.Utils
20 import Ganeti.HTools.Types
22 -- | Parse the basic specifications of an instance.
24 -- Instances in the cluster instance list and the instance in an
25 -- 'Allocate' request share some common properties, which are read by
27 parseBaseInstance :: String
29 -> Result (String, Instance.Instance)
30 parseBaseInstance n a = do
31 disk <- case fromObj "disk_usage" a of
33 all_d <- fromObj "disks" a >>= asObjectList
34 szd <- mapM (fromObj "size") all_d
35 let sze = map (+128) szd
39 mem <- fromObj "memory" a
40 let running = "running"
41 return $ (n, Instance.create n mem disk running 0 0)
43 -- | Parses an instance as found in the cluster instance list.
44 parseInstance :: NameAssoc -- ^ The node name-to-index association list
45 -> String -- ^ The name of the instance
46 -> JSObject JSValue -- ^ The JSON object
47 -> Result (String, Instance.Instance)
48 parseInstance ktn n a = do
49 base <- parseBaseInstance n a
50 nodes <- fromObj "nodes" a
51 pnode <- readEitherString $ head nodes
52 pidx <- lookupNode ktn n pnode
53 let snodes = tail nodes
54 sidx <- (if null snodes then return Node.noSecondary
55 else (readEitherString $ head snodes) >>= lookupNode ktn n)
56 return (n, Instance.setBoth (snd base) pidx sidx)
58 -- | Parses a node as found in the cluster node list.
59 parseNode :: String -- ^ The node's name
60 -> JSObject JSValue -- ^ The JSON object
61 -> Result (String, Node.Node)
64 offline <- fromObj "offline" a
65 drained <- fromObj "drained" a
66 node <- (case offline of
67 True -> return $ Node.create name 0 0 0 0 0 True
69 mtotal <- fromObj "total_memory" a
70 mnode <- fromObj "reserved_memory" a
71 mfree <- fromObj "free_memory" a
72 dtotal <- fromObj "total_disk" a
73 dfree <- fromObj "free_disk" a
74 return $ Node.create n mtotal mnode mfree
75 dtotal dfree (offline || drained))
78 -- | Top-level parser.
79 parseData :: String -- ^ The JSON message as received from Ganeti
80 -> Result Request -- ^ A (possible valid) request
82 decoded <- fromJResult $ decodeStrict body
85 request <- fromObj "request" obj
86 rname <- fromObj "name" request
87 -- existing node parsing
88 nlist <- fromObj "nodes" obj
89 let ndata = fromJSObject nlist
90 nobj <- (mapM (\(x,y) -> asJSObject y >>= parseNode x)) ndata
91 let (ktn, nl) = assignIndices nobj
92 -- existing instance parsing
93 ilist <- fromObj "instances" obj
94 let idata = fromJSObject ilist
95 iobj <- (mapM (\(x,y) -> asJSObject y >>= parseInstance ktn x)) idata
96 let (kti, il) = assignIndices iobj
97 (map_n, map_i, csf) <- mergeData (nl, il)
98 req_nodes <- fromObj "required_nodes" request
99 optype <- fromObj "type" request
104 inew <- parseBaseInstance rname request
106 return $ Allocate io req_nodes
109 ridx <- lookupInstance kti rname
110 ex_nodes <- fromObj "relocate_from" request
111 let ex_nodes' = map (stripSuffix $ length csf) ex_nodes
112 ex_idex <- mapM (Container.findByName map_n) ex_nodes'
113 return $ Relocate ridx req_nodes ex_idex
114 other -> fail $ ("Invalid request type '" ++ other ++ "'")
115 return $ Request rqtype map_n map_i csf
117 -- | Formats the response into a valid IAllocator response message.
118 formatResponse :: Bool -- ^ Whether the request was successful
119 -> String -- ^ Information text
120 -> [String] -- ^ The list of chosen nodes
121 -> String -- ^ The JSON-formatted message
122 formatResponse success info nodes =
124 e_success = ("success", JSBool success)
125 e_info = ("info", JSString . toJSString $ info)
126 e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
127 in encodeStrict $ makeObj [e_success, e_info, e_nodes]