root / Ganeti / HTools / IAlloc.hs @ b513faa1
History | View | Annotate | Download (3.7 kB)
1 |
{-| Implementation of the iallocator interface. |
---|---|
2 |
|
3 |
-} |
4 |
|
5 |
module Ganeti.HTools.IAlloc |
6 |
( |
7 |
parseData |
8 |
, formatResponse |
9 |
) where |
10 |
|
11 |
import Data.Either () |
12 |
--import Data.Maybe |
13 |
import Control.Monad |
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 |
23 |
|
24 |
data RqType |
25 |
= Allocate String Instance.Instance |
26 |
| Relocate Int |
27 |
deriving (Show) |
28 |
|
29 |
data Request = Request RqType NodeList InstanceList String NameList NameList |
30 |
deriving (Show) |
31 |
|
32 |
parseBaseInstance :: String |
33 |
-> JSObject JSValue |
34 |
-> Result (String, Instance.Instance) |
35 |
parseBaseInstance n a = do |
36 |
disk <- case fromObj "disk_usage" a of |
37 |
Bad _ -> do |
38 |
all_d <- fromObj "disks" a >>= asObjectList |
39 |
szd <- mapM (fromObj "size") all_d |
40 |
let sze = map (+128) szd |
41 |
szf = (sum sze)::Int |
42 |
return szf |
43 |
x@(Ok _) -> x |
44 |
mem <- fromObj "memory" a |
45 |
let running = "running" |
46 |
return $ (n, Instance.create n mem disk running 0 0) |
47 |
|
48 |
parseInstance :: NameAssoc |
49 |
-> String |
50 |
-> JSObject JSValue |
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) |
60 |
|
61 |
parseNode :: String -> JSObject JSValue -> Result (String, Node.Node) |
62 |
parseNode n a = do |
63 |
let name = n |
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 n mtotal mnode mfree dtotal dfree |
72 |
(offline || drained)) |
73 |
|
74 |
parseData :: String -> Result Request |
75 |
parseData body = do |
76 |
decoded <- fromJResult $ decodeStrict body |
77 |
let obj = decoded |
78 |
-- request parser |
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 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 iobj |
91 |
optype <- fromObj "type" request |
92 |
rqtype <- |
93 |
case optype of |
94 |
"allocate" -> |
95 |
do |
96 |
inew <- parseBaseInstance rname request |
97 |
let (iname, io) = inew |
98 |
return $ Allocate iname io |
99 |
"relocate" -> |
100 |
do |
101 |
ridx <- lookupNode kti rname rname |
102 |
return $ Relocate ridx |
103 |
other -> fail $ ("Invalid request type '" ++ other ++ "'") |
104 |
(map_n, map_i, csf, xtn, xti) <- mergeData (ktn, nl, kti, il) |
105 |
return $ Request rqtype map_n map_i csf xtn xti |
106 |
|
107 |
formatResponse :: Bool -> String -> [String] -> String |
108 |
formatResponse success info nodes = |
109 |
let |
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] |