root / Ganeti / HTools / IAlloc.hs @ 3f6af65c
History | View | Annotate | Download (3.6 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 |
15 |
import Text.Printf (printf) |
16 |
import Ganeti.HTools.Utils |
17 |
|
18 |
parseInstance :: String -> JSObject JSValue -> Either String String |
19 |
parseInstance n a = |
20 |
let name = Right n |
21 |
disk = case getIntElement "disk_usage" a of |
22 |
Left _ -> let all_d = getListElement "disks" a `combineEithers` |
23 |
asObjectList |
24 |
szd = all_d `combineEithers` |
25 |
(ensureEitherList . |
26 |
map (getIntElement "size")) |
27 |
sze = applyEither1 (map (+128)) szd |
28 |
szf = applyEither1 sum sze |
29 |
in szf |
30 |
Right x -> Right x |
31 |
nodes = getListElement "nodes" a |
32 |
pnode = eitherListHead nodes |
33 |
`combineEithers` readEitherString |
34 |
snode = applyEither1 (head . tail) nodes |
35 |
`combineEithers` readEitherString |
36 |
mem = getIntElement "memory" a |
37 |
running = Right "running" --getStringElement "status" a |
38 |
in |
39 |
concatEitherElems name $ |
40 |
concatEitherElems (show `applyEither1` mem) $ |
41 |
concatEitherElems (show `applyEither1` disk) $ |
42 |
concatEitherElems running $ |
43 |
concatEitherElems pnode snode |
44 |
|
45 |
parseNode :: String -> JSObject JSValue -> Either String String |
46 |
parseNode n a = |
47 |
let name = Right n |
48 |
mtotal = getIntElement "total_memory" a |
49 |
mnode = getIntElement "reserved_memory" a |
50 |
mfree = getIntElement "free_memory" a |
51 |
dtotal = getIntElement "total_disk" a |
52 |
dfree = getIntElement "free_disk" a |
53 |
in concatEitherElems name $ |
54 |
concatEitherElems (show `applyEither1` mtotal) $ |
55 |
concatEitherElems (show `applyEither1` mnode) $ |
56 |
concatEitherElems (show `applyEither1` mfree) $ |
57 |
concatEitherElems (show `applyEither1` dtotal) |
58 |
(show `applyEither1` dfree) |
59 |
|
60 |
parseData :: String -> Either String (String, String) |
61 |
parseData body = |
62 |
let |
63 |
decoded = resultToEither $ decodeStrict body |
64 |
obj = decoded -- decoded `combineEithers` fromJSObject |
65 |
request = obj `combineEithers` getObjectElement "request" |
66 |
rname = request `combineEithers` getStringElement "name" |
67 |
ilist = obj `combineEithers` getObjectElement "instances" |
68 |
nlist = obj `combineEithers` getObjectElement "nodes" |
69 |
idata = applyEither1 fromJSObject ilist |
70 |
ndata = applyEither1 fromJSObject nlist |
71 |
iobj = idata `combineEithers` (ensureEitherList . |
72 |
map (\(x,y) -> |
73 |
asJSObject y `combineEithers` |
74 |
parseInstance x)) |
75 |
ilines = iobj `combineEithers` (Right . unlines) |
76 |
nobj = ndata `combineEithers` (ensureEitherList . |
77 |
map (\(x,y) -> |
78 |
asJSObject y `combineEithers` |
79 |
parseNode x)) |
80 |
nlines = nobj `combineEithers` (Right . unlines) |
81 |
in applyEither2 (,) nlines ilines |
82 |
|
83 |
formatResponse :: Bool -> String -> [String] -> String |
84 |
formatResponse success info nodes = |
85 |
let |
86 |
e_success = ("success", JSBool success) |
87 |
e_info = ("info", JSString . toJSString $ info) |
88 |
e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes) |
89 |
in encodeStrict $ makeObj [e_success, e_info, e_nodes] |