root / Ganeti / HTools / IAlloc.hs @ 608efcce
History | View | Annotate | Download (4.2 kB)
1 | 43643696 | Iustin Pop | {-| Implementation of the iallocator interface. |
---|---|---|---|
2 | 43643696 | Iustin Pop | |
3 | 43643696 | Iustin Pop | -} |
4 | 43643696 | Iustin Pop | |
5 | 43643696 | Iustin Pop | module Ganeti.HTools.IAlloc |
6 | 43643696 | Iustin Pop | ( |
7 | 43643696 | Iustin Pop | parseData |
8 | 43643696 | Iustin Pop | , formatResponse |
9 | ed41c179 | Iustin Pop | , RqType(..) |
10 | ed41c179 | Iustin Pop | , Request(..) |
11 | 43643696 | Iustin Pop | ) where |
12 | 43643696 | Iustin Pop | |
13 | 43643696 | Iustin Pop | import Data.Either () |
14 | 585d4420 | Iustin Pop | --import Data.Maybe |
15 | 43643696 | Iustin Pop | import Control.Monad |
16 | 942403e6 | Iustin Pop | import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray), |
17 | 942403e6 | Iustin Pop | makeObj, encodeStrict, decodeStrict, |
18 | 942403e6 | Iustin Pop | fromJSObject, toJSString) |
19 | 585d4420 | Iustin Pop | --import Text.Printf (printf) |
20 | 262a08a2 | Iustin Pop | import qualified Ganeti.HTools.Container as Container |
21 | 942403e6 | Iustin Pop | import qualified Ganeti.HTools.Node as Node |
22 | 942403e6 | Iustin Pop | import qualified Ganeti.HTools.Instance as Instance |
23 | e4c5beaf | Iustin Pop | import Ganeti.HTools.Loader |
24 | e4c5beaf | Iustin Pop | import Ganeti.HTools.Utils |
25 | e4c5beaf | Iustin Pop | import Ganeti.HTools.Types |
26 | 43643696 | Iustin Pop | |
27 | 144f190b | Iustin Pop | data RqType |
28 | ed41c179 | Iustin Pop | = Allocate Instance.Instance Int |
29 | 608efcce | Iustin Pop | | Relocate Idx Int [Ndx] |
30 | e4c5beaf | Iustin Pop | deriving (Show) |
31 | 144f190b | Iustin Pop | |
32 | 262a08a2 | Iustin Pop | data Request = Request RqType Node.List Instance.List String |
33 | 585d4420 | Iustin Pop | deriving (Show) |
34 | 942403e6 | Iustin Pop | |
35 | e4c5beaf | Iustin Pop | parseBaseInstance :: String |
36 | e4c5beaf | Iustin Pop | -> JSObject JSValue |
37 | e4c5beaf | Iustin Pop | -> Result (String, Instance.Instance) |
38 | e4c5beaf | Iustin Pop | parseBaseInstance n a = do |
39 | e4c5beaf | Iustin Pop | disk <- case fromObj "disk_usage" a of |
40 | e4c5beaf | Iustin Pop | Bad _ -> do |
41 | e4c5beaf | Iustin Pop | all_d <- fromObj "disks" a >>= asObjectList |
42 | e4c5beaf | Iustin Pop | szd <- mapM (fromObj "size") all_d |
43 | e4c5beaf | Iustin Pop | let sze = map (+128) szd |
44 | e4c5beaf | Iustin Pop | szf = (sum sze)::Int |
45 | e4c5beaf | Iustin Pop | return szf |
46 | e4c5beaf | Iustin Pop | x@(Ok _) -> x |
47 | e4c5beaf | Iustin Pop | mem <- fromObj "memory" a |
48 | e4c5beaf | Iustin Pop | let running = "running" |
49 | 2727257a | Iustin Pop | return $ (n, Instance.create n mem disk running 0 0) |
50 | 585d4420 | Iustin Pop | |
51 | e4c5beaf | Iustin Pop | parseInstance :: NameAssoc |
52 | e4c5beaf | Iustin Pop | -> String |
53 | e4c5beaf | Iustin Pop | -> JSObject JSValue |
54 | e4c5beaf | Iustin Pop | -> Result (String, Instance.Instance) |
55 | e4c5beaf | Iustin Pop | parseInstance ktn n a = do |
56 | 585d4420 | Iustin Pop | base <- parseBaseInstance n a |
57 | e4c5beaf | Iustin Pop | nodes <- fromObj "nodes" a |
58 | e4c5beaf | Iustin Pop | pnode <- readEitherString $ head nodes |
59 | e4c5beaf | Iustin Pop | pidx <- lookupNode ktn n pnode |
60 | bd1794b2 | Iustin Pop | let snodes = tail nodes |
61 | bd1794b2 | Iustin Pop | sidx <- (if null snodes then return Node.noSecondary |
62 | bd1794b2 | Iustin Pop | else (readEitherString $ head snodes) >>= lookupNode ktn n) |
63 | e4c5beaf | Iustin Pop | return (n, Instance.setBoth (snd base) pidx sidx) |
64 | 585d4420 | Iustin Pop | |
65 | e4c5beaf | Iustin Pop | parseNode :: String -> JSObject JSValue -> Result (String, Node.Node) |
66 | e4c5beaf | Iustin Pop | parseNode n a = do |
67 | e4c5beaf | Iustin Pop | let name = n |
68 | e4c5beaf | Iustin Pop | offline <- fromObj "offline" a |
69 | 8c2ebac8 | Iustin Pop | drained <- fromObj "drained" a |
70 | 1de50907 | Iustin Pop | node <- (case offline of |
71 | 1de50907 | Iustin Pop | True -> return $ Node.create name 0 0 0 0 0 True |
72 | 1de50907 | Iustin Pop | _ -> do |
73 | 1de50907 | Iustin Pop | mtotal <- fromObj "total_memory" a |
74 | 1de50907 | Iustin Pop | mnode <- fromObj "reserved_memory" a |
75 | 1de50907 | Iustin Pop | mfree <- fromObj "free_memory" a |
76 | 1de50907 | Iustin Pop | dtotal <- fromObj "total_disk" a |
77 | 1de50907 | Iustin Pop | dfree <- fromObj "free_disk" a |
78 | 1de50907 | Iustin Pop | return $ Node.create n mtotal mnode mfree |
79 | 1de50907 | Iustin Pop | dtotal dfree (offline || drained)) |
80 | 1de50907 | Iustin Pop | return (name, node) |
81 | 144f190b | Iustin Pop | |
82 | 942403e6 | Iustin Pop | parseData :: String -> Result Request |
83 | e4c5beaf | Iustin Pop | parseData body = do |
84 | e4c5beaf | Iustin Pop | decoded <- fromJResult $ decodeStrict body |
85 | e4c5beaf | Iustin Pop | let obj = decoded |
86 | e4c5beaf | Iustin Pop | -- request parser |
87 | e4c5beaf | Iustin Pop | request <- fromObj "request" obj |
88 | e4c5beaf | Iustin Pop | rname <- fromObj "name" request |
89 | e4c5beaf | Iustin Pop | -- existing node parsing |
90 | e4c5beaf | Iustin Pop | nlist <- fromObj "nodes" obj |
91 | e4c5beaf | Iustin Pop | let ndata = fromJSObject nlist |
92 | e4c5beaf | Iustin Pop | nobj <- (mapM (\(x,y) -> asJSObject y >>= parseNode x)) ndata |
93 | 497e30a1 | Iustin Pop | let (ktn, nl) = assignIndices nobj |
94 | e4c5beaf | Iustin Pop | -- existing instance parsing |
95 | e4c5beaf | Iustin Pop | ilist <- fromObj "instances" obj |
96 | e4c5beaf | Iustin Pop | let idata = fromJSObject ilist |
97 | e4c5beaf | Iustin Pop | iobj <- (mapM (\(x,y) -> asJSObject y >>= parseInstance ktn x)) idata |
98 | 497e30a1 | Iustin Pop | let (kti, il) = assignIndices iobj |
99 | ed41c179 | Iustin Pop | (map_n, map_i, csf) <- mergeData (nl, il) |
100 | ed41c179 | Iustin Pop | req_nodes <- fromObj "required_nodes" request |
101 | e4c5beaf | Iustin Pop | optype <- fromObj "type" request |
102 | e4c5beaf | Iustin Pop | rqtype <- |
103 | e4c5beaf | Iustin Pop | case optype of |
104 | e4c5beaf | Iustin Pop | "allocate" -> |
105 | e4c5beaf | Iustin Pop | do |
106 | e4c5beaf | Iustin Pop | inew <- parseBaseInstance rname request |
107 | ed41c179 | Iustin Pop | let io = snd inew |
108 | ed41c179 | Iustin Pop | return $ Allocate io req_nodes |
109 | e4c5beaf | Iustin Pop | "relocate" -> |
110 | e4c5beaf | Iustin Pop | do |
111 | e4c5beaf | Iustin Pop | ridx <- lookupNode kti rname rname |
112 | ed41c179 | Iustin Pop | ex_nodes <- fromObj "relocate_from" request |
113 | ed41c179 | Iustin Pop | let ex_nodes' = map (stripSuffix $ length csf) ex_nodes |
114 | 262a08a2 | Iustin Pop | ex_idex <- mapM (Container.findByName map_n) ex_nodes' |
115 | ed41c179 | Iustin Pop | return $ Relocate ridx req_nodes ex_idex |
116 | e4c5beaf | Iustin Pop | other -> fail $ ("Invalid request type '" ++ other ++ "'") |
117 | 8472a321 | Iustin Pop | return $ Request rqtype map_n map_i csf |
118 | 942403e6 | Iustin Pop | |
119 | 43643696 | Iustin Pop | formatResponse :: Bool -> String -> [String] -> String |
120 | 43643696 | Iustin Pop | formatResponse success info nodes = |
121 | 43643696 | Iustin Pop | let |
122 | 43643696 | Iustin Pop | e_success = ("success", JSBool success) |
123 | 43643696 | Iustin Pop | e_info = ("info", JSString . toJSString $ info) |
124 | 43643696 | Iustin Pop | e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes) |
125 | 43643696 | Iustin Pop | in encodeStrict $ makeObj [e_success, e_info, e_nodes] |