1 {-| Implementation of the iallocator interface.
5 module Ganeti.HTools.IAlloc
14 import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
15 makeObj, encodeStrict, decodeStrict,
16 fromJSObject, toJSString)
17 --import Text.Printf (printf)
18 import qualified Ganeti.HTools.Node as Node
19 import qualified Ganeti.HTools.Instance as Instance
20 import Ganeti.HTools.Loader
21 import Ganeti.HTools.Utils
22 import Ganeti.HTools.Types
25 = Allocate String Instance.Instance
29 data Request = Request RqType IdxNode IdxInstance NameList NameList
32 parseBaseInstance :: String
34 -> Result (String, Instance.Instance)
35 parseBaseInstance n a = do
36 disk <- case fromObj "disk_usage" a of
38 all_d <- fromObj "disks" a >>= asObjectList
39 szd <- mapM (fromObj "size") all_d
40 let sze = map (+128) szd
44 mem <- fromObj "memory" a
45 let running = "running"
46 return $ (n, Instance.create mem disk running 0 0)
48 parseInstance :: NameAssoc
51 -> Result (String, Instance.Instance)
52 parseInstance ktn n a = do
53 base <- parseBaseInstance n a
54 nodes <- fromObj "nodes" a
55 pnode <- readEitherString $ head nodes
56 snode <- readEitherString $ (head . tail) nodes
57 pidx <- lookupNode ktn n pnode
58 sidx <- lookupNode ktn n snode
59 return (n, Instance.setBoth (snd base) pidx sidx)
61 parseNode :: String -> JSObject JSValue -> Result (String, Node.Node)
64 mtotal <- fromObj "total_memory" a
65 mnode <- fromObj "reserved_memory" a
66 mfree <- fromObj "free_memory" a
67 dtotal <- fromObj "total_disk" a
68 dfree <- fromObj "free_disk" a
69 offline <- fromObj "offline" a
70 drained <- fromObj "offline" a
71 return $ (name, Node.create mtotal mnode mfree dtotal dfree
74 parseData :: String -> Result Request
76 decoded <- fromJResult $ decodeStrict body
79 request <- fromObj "request" obj
80 rname <- fromObj "name" request
81 -- existing node parsing
82 nlist <- fromObj "nodes" obj
83 let ndata = fromJSObject nlist
84 nobj <- (mapM (\(x,y) -> asJSObject y >>= parseNode x)) ndata
85 let (ktn, nl) = assignIndices Node.setIdx nobj
86 -- existing instance parsing
87 ilist <- fromObj "instances" obj
88 let idata = fromJSObject ilist
89 iobj <- (mapM (\(x,y) -> asJSObject y >>= parseInstance ktn x)) idata
90 let (kti, il) = assignIndices Instance.setIdx iobj
91 optype <- fromObj "type" request
96 inew <- parseBaseInstance rname request
97 let (iname, io) = inew
98 return $ Allocate iname io
101 ridx <- lookupNode kti rname rname
102 return $ Relocate ridx
103 other -> fail $ ("Invalid request type '" ++ other ++ "'")
105 return $ Request rqtype nl il (swapPairs ktn) (swapPairs kti)
107 formatResponse :: Bool -> String -> [String] -> String
108 formatResponse success info nodes =
110 e_success = ("success", JSBool success)
111 e_info = ("info", JSString . toJSString $ info)
112 e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
113 in encodeStrict $ makeObj [e_success, e_info, e_nodes]