root / Ganeti / HTools / IAlloc.hs @ 669ea132
History | View | Annotate | Download (5.5 kB)
1 | 43643696 | Iustin Pop | {-| Implementation of the iallocator interface. |
---|---|---|---|
2 | 43643696 | Iustin Pop | |
3 | 43643696 | Iustin Pop | -} |
4 | 43643696 | Iustin Pop | |
5 | e2fa2baf | Iustin Pop | {- |
6 | e2fa2baf | Iustin Pop | |
7 | e2fa2baf | Iustin Pop | Copyright (C) 2009 Google Inc. |
8 | e2fa2baf | Iustin Pop | |
9 | e2fa2baf | Iustin Pop | This program is free software; you can redistribute it and/or modify |
10 | e2fa2baf | Iustin Pop | it under the terms of the GNU General Public License as published by |
11 | e2fa2baf | Iustin Pop | the Free Software Foundation; either version 2 of the License, or |
12 | e2fa2baf | Iustin Pop | (at your option) any later version. |
13 | e2fa2baf | Iustin Pop | |
14 | e2fa2baf | Iustin Pop | This program is distributed in the hope that it will be useful, but |
15 | e2fa2baf | Iustin Pop | WITHOUT ANY WARRANTY; without even the implied warranty of |
16 | e2fa2baf | Iustin Pop | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
17 | e2fa2baf | Iustin Pop | General Public License for more details. |
18 | e2fa2baf | Iustin Pop | |
19 | e2fa2baf | Iustin Pop | You should have received a copy of the GNU General Public License |
20 | e2fa2baf | Iustin Pop | along with this program; if not, write to the Free Software |
21 | e2fa2baf | Iustin Pop | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
22 | e2fa2baf | Iustin Pop | 02110-1301, USA. |
23 | e2fa2baf | Iustin Pop | |
24 | e2fa2baf | Iustin Pop | -} |
25 | e2fa2baf | Iustin Pop | |
26 | 43643696 | Iustin Pop | module Ganeti.HTools.IAlloc |
27 | 19f38ee8 | Iustin Pop | ( parseData |
28 | 43643696 | Iustin Pop | , formatResponse |
29 | 43643696 | Iustin Pop | ) where |
30 | 43643696 | Iustin Pop | |
31 | 43643696 | Iustin Pop | import Data.Either () |
32 | 43643696 | Iustin Pop | import Control.Monad |
33 | 942403e6 | Iustin Pop | import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray), |
34 | 942403e6 | Iustin Pop | makeObj, encodeStrict, decodeStrict, |
35 | 942403e6 | Iustin Pop | fromJSObject, toJSString) |
36 | 262a08a2 | Iustin Pop | import qualified Ganeti.HTools.Container as Container |
37 | 942403e6 | Iustin Pop | import qualified Ganeti.HTools.Node as Node |
38 | 942403e6 | Iustin Pop | import qualified Ganeti.HTools.Instance as Instance |
39 | e4c5beaf | Iustin Pop | import Ganeti.HTools.Loader |
40 | e4c5beaf | Iustin Pop | import Ganeti.HTools.Utils |
41 | e4c5beaf | Iustin Pop | import Ganeti.HTools.Types |
42 | 43643696 | Iustin Pop | |
43 | 9188aeef | Iustin Pop | -- | Parse the basic specifications of an instance. |
44 | 9188aeef | Iustin Pop | -- |
45 | 9188aeef | Iustin Pop | -- Instances in the cluster instance list and the instance in an |
46 | 9188aeef | Iustin Pop | -- 'Allocate' request share some common properties, which are read by |
47 | 9188aeef | Iustin Pop | -- this function. |
48 | e4c5beaf | Iustin Pop | parseBaseInstance :: String |
49 | 262f3e6c | Iustin Pop | -> [(String, JSValue)] |
50 | e4c5beaf | Iustin Pop | -> Result (String, Instance.Instance) |
51 | e4c5beaf | Iustin Pop | parseBaseInstance n a = do |
52 | 734b1ff1 | Iustin Pop | disk <- fromObj "disk_space_total" a |
53 | e4c5beaf | Iustin Pop | mem <- fromObj "memory" a |
54 | d752eb39 | Iustin Pop | vcpus <- fromObj "vcpus" a |
55 | 17e7af2b | Iustin Pop | tags <- fromObj "tags" a |
56 | e4c5beaf | Iustin Pop | let running = "running" |
57 | 17e7af2b | Iustin Pop | return (n, Instance.create n mem disk vcpus running tags 0 0) |
58 | 585d4420 | Iustin Pop | |
59 | 262f3e6c | Iustin Pop | -- | Parses an instance as found in the cluster instance listg. |
60 | 9188aeef | Iustin Pop | parseInstance :: NameAssoc -- ^ The node name-to-index association list |
61 | 9188aeef | Iustin Pop | -> String -- ^ The name of the instance |
62 | 262f3e6c | Iustin Pop | -> [(String, JSValue)] -- ^ The JSON object |
63 | e4c5beaf | Iustin Pop | -> Result (String, Instance.Instance) |
64 | e4c5beaf | Iustin Pop | parseInstance ktn n a = do |
65 | 262f3e6c | Iustin Pop | base <- parseBaseInstance n a |
66 | 262f3e6c | Iustin Pop | nodes <- fromObj "nodes" a |
67 | 262f3e6c | Iustin Pop | pnode <- readEitherString $ head nodes |
68 | 262f3e6c | Iustin Pop | pidx <- lookupNode ktn n pnode |
69 | 262f3e6c | Iustin Pop | let snodes = tail nodes |
70 | 262f3e6c | Iustin Pop | sidx <- (if null snodes then return Node.noSecondary |
71 | 262f3e6c | Iustin Pop | else readEitherString (head snodes) >>= lookupNode ktn n) |
72 | 262f3e6c | Iustin Pop | return (n, Instance.setBoth (snd base) pidx sidx) |
73 | 585d4420 | Iustin Pop | |
74 | 9188aeef | Iustin Pop | -- | Parses a node as found in the cluster node list. |
75 | 9188aeef | Iustin Pop | parseNode :: String -- ^ The node's name |
76 | 262f3e6c | Iustin Pop | -> [(String, JSValue)] -- ^ The JSON object |
77 | 9188aeef | Iustin Pop | -> Result (String, Node.Node) |
78 | e4c5beaf | Iustin Pop | parseNode n a = do |
79 | 262f3e6c | Iustin Pop | offline <- fromObj "offline" a |
80 | 262f3e6c | Iustin Pop | drained <- fromObj "drained" a |
81 | 262f3e6c | Iustin Pop | node <- (if offline || drained |
82 | 262f3e6c | Iustin Pop | then return $ Node.create n 0 0 0 0 0 0 True |
83 | 262f3e6c | Iustin Pop | else do |
84 | 262f3e6c | Iustin Pop | mtotal <- fromObj "total_memory" a |
85 | 262f3e6c | Iustin Pop | mnode <- fromObj "reserved_memory" a |
86 | 262f3e6c | Iustin Pop | mfree <- fromObj "free_memory" a |
87 | 262f3e6c | Iustin Pop | dtotal <- fromObj "total_disk" a |
88 | 262f3e6c | Iustin Pop | dfree <- fromObj "free_disk" a |
89 | 262f3e6c | Iustin Pop | ctotal <- fromObj "total_cpus" a |
90 | 262f3e6c | Iustin Pop | return $ Node.create n mtotal mnode mfree |
91 | 262f3e6c | Iustin Pop | dtotal dfree ctotal False) |
92 | 262f3e6c | Iustin Pop | return (n, node) |
93 | 144f190b | Iustin Pop | |
94 | 9188aeef | Iustin Pop | -- | Top-level parser. |
95 | 9188aeef | Iustin Pop | parseData :: String -- ^ The JSON message as received from Ganeti |
96 | 9188aeef | Iustin Pop | -> Result Request -- ^ A (possible valid) request |
97 | e4c5beaf | Iustin Pop | parseData body = do |
98 | e4c5beaf | Iustin Pop | decoded <- fromJResult $ decodeStrict body |
99 | 262f3e6c | Iustin Pop | let obj = fromJSObject decoded |
100 | e4c5beaf | Iustin Pop | -- request parser |
101 | 262f3e6c | Iustin Pop | request <- liftM fromJSObject (fromObj "request" obj) |
102 | e4c5beaf | Iustin Pop | rname <- fromObj "name" request |
103 | e4c5beaf | Iustin Pop | -- existing node parsing |
104 | 262f3e6c | Iustin Pop | nlist <- liftM fromJSObject (fromObj "nodes" obj) |
105 | 262f3e6c | Iustin Pop | nobj <- mapM (\(x,y) -> asJSObject y >>= parseNode x . fromJSObject) nlist |
106 | 497e30a1 | Iustin Pop | let (ktn, nl) = assignIndices nobj |
107 | e4c5beaf | Iustin Pop | -- existing instance parsing |
108 | e4c5beaf | Iustin Pop | ilist <- fromObj "instances" obj |
109 | e4c5beaf | Iustin Pop | let idata = fromJSObject ilist |
110 | 262f3e6c | Iustin Pop | iobj <- mapM (\(x,y) -> |
111 | 262f3e6c | Iustin Pop | asJSObject y >>= parseInstance ktn x . fromJSObject) idata |
112 | 497e30a1 | Iustin Pop | let (kti, il) = assignIndices iobj |
113 | 669ea132 | Iustin Pop | -- cluster tags |
114 | 669ea132 | Iustin Pop | ctags <- fromObj "cluster_tags" obj |
115 | 669ea132 | Iustin Pop | (map_n, map_i, ptags, csf) <- mergeData [] [] (nl, il, ctags) |
116 | ed41c179 | Iustin Pop | req_nodes <- fromObj "required_nodes" request |
117 | e4c5beaf | Iustin Pop | optype <- fromObj "type" request |
118 | e4c5beaf | Iustin Pop | rqtype <- |
119 | e4c5beaf | Iustin Pop | case optype of |
120 | e4c5beaf | Iustin Pop | "allocate" -> |
121 | e4c5beaf | Iustin Pop | do |
122 | e4c5beaf | Iustin Pop | inew <- parseBaseInstance rname request |
123 | ed41c179 | Iustin Pop | let io = snd inew |
124 | ed41c179 | Iustin Pop | return $ Allocate io req_nodes |
125 | e4c5beaf | Iustin Pop | "relocate" -> |
126 | e4c5beaf | Iustin Pop | do |
127 | 5a1edeb6 | Iustin Pop | ridx <- lookupInstance kti rname |
128 | ed41c179 | Iustin Pop | ex_nodes <- fromObj "relocate_from" request |
129 | ed41c179 | Iustin Pop | let ex_nodes' = map (stripSuffix $ length csf) ex_nodes |
130 | 262a08a2 | Iustin Pop | ex_idex <- mapM (Container.findByName map_n) ex_nodes' |
131 | e7724ccc | Iustin Pop | return $ Relocate ridx req_nodes (map Node.idx ex_idex) |
132 | 9f6dcdea | Iustin Pop | other -> fail ("Invalid request type '" ++ other ++ "'") |
133 | 669ea132 | Iustin Pop | return $ Request rqtype map_n map_i ptags csf |
134 | 942403e6 | Iustin Pop | |
135 | 9188aeef | Iustin Pop | -- | Formats the response into a valid IAllocator response message. |
136 | 9188aeef | Iustin Pop | formatResponse :: Bool -- ^ Whether the request was successful |
137 | 9188aeef | Iustin Pop | -> String -- ^ Information text |
138 | 9188aeef | Iustin Pop | -> [String] -- ^ The list of chosen nodes |
139 | 9188aeef | Iustin Pop | -> String -- ^ The JSON-formatted message |
140 | 43643696 | Iustin Pop | formatResponse success info nodes = |
141 | 43643696 | Iustin Pop | let |
142 | 43643696 | Iustin Pop | e_success = ("success", JSBool success) |
143 | 43643696 | Iustin Pop | e_info = ("info", JSString . toJSString $ info) |
144 | 43643696 | Iustin Pop | e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes) |
145 | 43643696 | Iustin Pop | in encodeStrict $ makeObj [e_success, e_info, e_nodes] |