root / Ganeti / HTools / IAlloc.hs @ e2fa2baf
History | View | Annotate | Download (5.5 kB)
1 |
{-| Implementation of the iallocator interface. |
---|---|
2 |
|
3 |
-} |
4 |
|
5 |
{- |
6 |
|
7 |
Copyright (C) 2009 Google Inc. |
8 |
|
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. |
13 |
|
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. |
18 |
|
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 |
22 |
02110-1301, USA. |
23 |
|
24 |
-} |
25 |
|
26 |
module Ganeti.HTools.IAlloc |
27 |
( parseData |
28 |
, formatResponse |
29 |
) where |
30 |
|
31 |
import Data.Either () |
32 |
import Control.Monad |
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 |
42 |
|
43 |
-- | Parse the basic specifications of an instance. |
44 |
-- |
45 |
-- Instances in the cluster instance list and the instance in an |
46 |
-- 'Allocate' request share some common properties, which are read by |
47 |
-- this function. |
48 |
parseBaseInstance :: String |
49 |
-> JSObject JSValue |
50 |
-> Result (String, Instance.Instance) |
51 |
parseBaseInstance n a = do |
52 |
disk <- case fromObj "disk_usage" a of |
53 |
Bad _ -> do |
54 |
all_d <- fromObj "disks" a >>= asObjectList |
55 |
szd <- mapM (fromObj "size") all_d |
56 |
let sze = map (+128) szd |
57 |
szf = (sum sze)::Int |
58 |
return szf |
59 |
x@(Ok _) -> x |
60 |
mem <- fromObj "memory" a |
61 |
let running = "running" |
62 |
return $ (n, Instance.create n mem disk running 0 0) |
63 |
|
64 |
-- | Parses an instance as found in the cluster instance list. |
65 |
parseInstance :: NameAssoc -- ^ The node name-to-index association list |
66 |
-> String -- ^ The name of the instance |
67 |
-> JSObject JSValue -- ^ The JSON object |
68 |
-> Result (String, Instance.Instance) |
69 |
parseInstance ktn n a = do |
70 |
base <- parseBaseInstance n a |
71 |
nodes <- fromObj "nodes" a |
72 |
pnode <- readEitherString $ head nodes |
73 |
pidx <- lookupNode ktn n pnode |
74 |
let snodes = tail nodes |
75 |
sidx <- (if null snodes then return Node.noSecondary |
76 |
else (readEitherString $ head snodes) >>= lookupNode ktn n) |
77 |
return (n, Instance.setBoth (snd base) pidx sidx) |
78 |
|
79 |
-- | Parses a node as found in the cluster node list. |
80 |
parseNode :: String -- ^ The node's name |
81 |
-> JSObject JSValue -- ^ The JSON object |
82 |
-> Result (String, Node.Node) |
83 |
parseNode n a = do |
84 |
let name = n |
85 |
offline <- fromObj "offline" a |
86 |
drained <- fromObj "drained" a |
87 |
node <- (case offline of |
88 |
True -> return $ Node.create name 0 0 0 0 0 True |
89 |
_ -> do |
90 |
mtotal <- fromObj "total_memory" a |
91 |
mnode <- fromObj "reserved_memory" a |
92 |
mfree <- fromObj "free_memory" a |
93 |
dtotal <- fromObj "total_disk" a |
94 |
dfree <- fromObj "free_disk" a |
95 |
return $ Node.create n mtotal mnode mfree |
96 |
dtotal dfree (offline || drained)) |
97 |
return (name, node) |
98 |
|
99 |
-- | Top-level parser. |
100 |
parseData :: String -- ^ The JSON message as received from Ganeti |
101 |
-> Result Request -- ^ A (possible valid) request |
102 |
parseData body = do |
103 |
decoded <- fromJResult $ decodeStrict body |
104 |
let obj = decoded |
105 |
-- request parser |
106 |
request <- fromObj "request" obj |
107 |
rname <- fromObj "name" request |
108 |
-- existing node parsing |
109 |
nlist <- fromObj "nodes" obj |
110 |
let ndata = fromJSObject nlist |
111 |
nobj <- (mapM (\(x,y) -> asJSObject y >>= parseNode x)) ndata |
112 |
let (ktn, nl) = assignIndices nobj |
113 |
-- existing instance parsing |
114 |
ilist <- fromObj "instances" obj |
115 |
let idata = fromJSObject ilist |
116 |
iobj <- (mapM (\(x,y) -> asJSObject y >>= parseInstance ktn x)) idata |
117 |
let (kti, il) = assignIndices iobj |
118 |
(map_n, map_i, csf) <- mergeData (nl, il) |
119 |
req_nodes <- fromObj "required_nodes" request |
120 |
optype <- fromObj "type" request |
121 |
rqtype <- |
122 |
case optype of |
123 |
"allocate" -> |
124 |
do |
125 |
inew <- parseBaseInstance rname request |
126 |
let io = snd inew |
127 |
return $ Allocate io req_nodes |
128 |
"relocate" -> |
129 |
do |
130 |
ridx <- lookupInstance kti rname |
131 |
ex_nodes <- fromObj "relocate_from" request |
132 |
let ex_nodes' = map (stripSuffix $ length csf) ex_nodes |
133 |
ex_idex <- mapM (Container.findByName map_n) ex_nodes' |
134 |
return $ Relocate ridx req_nodes ex_idex |
135 |
other -> fail $ ("Invalid request type '" ++ other ++ "'") |
136 |
return $ Request rqtype map_n map_i csf |
137 |
|
138 |
-- | Formats the response into a valid IAllocator response message. |
139 |
formatResponse :: Bool -- ^ Whether the request was successful |
140 |
-> String -- ^ Information text |
141 |
-> [String] -- ^ The list of chosen nodes |
142 |
-> String -- ^ The JSON-formatted message |
143 |
formatResponse success info nodes = |
144 |
let |
145 |
e_success = ("success", JSBool success) |
146 |
e_info = ("info", JSString . toJSString $ info) |
147 |
e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes) |
148 |
in encodeStrict $ makeObj [e_success, e_info, e_nodes] |