hail: add an extra safety check in relocate
[ganeti-local] / htools / Ganeti / HTools / IAlloc.hs
1 {-| Implementation of the iallocator interface.
2
3 -}
4
5 {-
6
7 Copyright (C) 2009, 2010, 2011 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     ( readRequest
28     , runIAllocator
29     ) where
30
31 import Data.Either ()
32 import Data.Maybe (fromMaybe, isJust)
33 import Data.List
34 import Control.Monad
35 import Text.JSON (JSObject, JSValue(JSArray),
36                   makeObj, encodeStrict, decodeStrict, fromJSObject, showJSON)
37 import System (exitWith, ExitCode(..))
38 import System.IO
39
40 import qualified Ganeti.HTools.Cluster as Cluster
41 import qualified Ganeti.HTools.Container as Container
42 import qualified Ganeti.HTools.Group as Group
43 import qualified Ganeti.HTools.Node as Node
44 import qualified Ganeti.HTools.Instance as Instance
45 import qualified Ganeti.Constants as C
46 import Ganeti.HTools.CLI
47 import Ganeti.HTools.Loader
48 import Ganeti.HTools.ExtLoader (loadExternalData)
49 import Ganeti.HTools.Utils
50 import Ganeti.HTools.Types
51
52 -- | Type alias for the result of an IAllocator call.
53 type IAllocResult = (String, JSValue, Node.List, Instance.List)
54
55 -- | Parse the basic specifications of an instance.
56 --
57 -- Instances in the cluster instance list and the instance in an
58 -- 'Allocate' request share some common properties, which are read by
59 -- this function.
60 parseBaseInstance :: String
61                   -> JSRecord
62                   -> Result (String, Instance.Instance)
63 parseBaseInstance n a = do
64   let extract x = tryFromObj ("invalid data for instance '" ++ n ++ "'") a x
65   disk  <- extract "disk_space_total"
66   mem   <- extract "memory"
67   vcpus <- extract "vcpus"
68   tags  <- extract "tags"
69   dt    <- extract "disk_template"
70   let running = "running"
71   return (n, Instance.create n mem disk vcpus running tags True 0 0 dt)
72
73 -- | Parses an instance as found in the cluster instance list.
74 parseInstance :: NameAssoc -- ^ The node name-to-index association list
75               -> String    -- ^ The name of the instance
76               -> JSRecord  -- ^ The JSON object
77               -> Result (String, Instance.Instance)
78 parseInstance ktn n a = do
79   base <- parseBaseInstance n a
80   nodes <- fromObj a "nodes"
81   pnode <- if null nodes
82            then Bad $ "empty node list for instance " ++ n
83            else readEitherString $ head nodes
84   pidx <- lookupNode ktn n pnode
85   let snodes = tail nodes
86   sidx <- (if null snodes then return Node.noSecondary
87            else readEitherString (head snodes) >>= lookupNode ktn n)
88   return (n, Instance.setBoth (snd base) pidx sidx)
89
90 -- | Parses a node as found in the cluster node list.
91 parseNode :: NameAssoc   -- ^ The group association
92           -> String      -- ^ The node's name
93           -> JSRecord    -- ^ The JSON object
94           -> Result (String, Node.Node)
95 parseNode ktg n a = do
96   let desc = "invalid data for node '" ++ n ++ "'"
97       extract x = tryFromObj desc a x
98   offline <- extract "offline"
99   drained <- extract "drained"
100   guuid   <- extract "group"
101   vm_capable  <- annotateResult desc $ maybeFromObj a "vm_capable"
102   let vm_capable' = fromMaybe True vm_capable
103   gidx <- lookupGroup ktg n guuid
104   node <- (if offline || drained || not vm_capable'
105            then return $ Node.create n 0 0 0 0 0 0 True gidx
106            else do
107              mtotal <- extract "total_memory"
108              mnode  <- extract "reserved_memory"
109              mfree  <- extract "free_memory"
110              dtotal <- extract "total_disk"
111              dfree  <- extract "free_disk"
112              ctotal <- extract "total_cpus"
113              return $ Node.create n mtotal mnode mfree
114                     dtotal dfree ctotal False gidx)
115   return (n, node)
116
117 -- | Parses a group as found in the cluster group list.
118 parseGroup :: String     -- ^ The group UUID
119            -> JSRecord   -- ^ The JSON object
120            -> Result (String, Group.Group)
121 parseGroup u a = do
122   let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x
123   name <- extract "name"
124   apol <- extract "alloc_policy"
125   return (u, Group.create name u apol)
126
127 -- | Top-level parser.
128 --
129 -- The result is a tuple of eventual warning messages and the parsed
130 -- request; if parsing the input data fails, we'll return a 'Bad'
131 -- value.
132 parseData :: String -- ^ The JSON message as received from Ganeti
133           -> Result ([String], Request) -- ^ Result tuple
134 parseData body = do
135   decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
136   let obj = fromJSObject decoded
137       extrObj x = tryFromObj "invalid iallocator message" obj x
138   -- request parser
139   request <- liftM fromJSObject (extrObj "request")
140   let extrReq x = tryFromObj "invalid request dict" request x
141   -- existing group parsing
142   glist <- liftM fromJSObject (extrObj "nodegroups")
143   gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist
144   let (ktg, gl) = assignIndices gobj
145   -- existing node parsing
146   nlist <- liftM fromJSObject (extrObj "nodes")
147   nobj <- mapM (\(x,y) ->
148                     asJSObject y >>= parseNode ktg x . fromJSObject) nlist
149   let (ktn, nl) = assignIndices nobj
150   -- existing instance parsing
151   ilist <- extrObj "instances"
152   let idata = fromJSObject ilist
153   iobj <- mapM (\(x,y) ->
154                     asJSObject y >>= parseInstance ktn x . fromJSObject) idata
155   let (kti, il) = assignIndices iobj
156   -- cluster tags
157   ctags <- extrObj "cluster_tags"
158   cdata1 <- mergeData [] [] [] [] (ClusterData gl nl il ctags)
159   let (msgs, fix_nl) = checkData (cdNodes cdata1) (cdInstances cdata1)
160       cdata = cdata1 { cdNodes = fix_nl }
161       map_n = cdNodes cdata
162       map_i = cdInstances cdata
163       map_g = cdGroups cdata
164   optype <- extrReq "type"
165   rqtype <-
166       case () of
167         _ | optype == C.iallocatorModeAlloc ->
168               do
169                 rname     <- extrReq "name"
170                 req_nodes <- extrReq "required_nodes"
171                 inew      <- parseBaseInstance rname request
172                 let io = snd inew
173                 return $ Allocate io req_nodes
174           | optype == C.iallocatorModeReloc ->
175               do
176                 rname     <- extrReq "name"
177                 ridx      <- lookupInstance kti rname
178                 req_nodes <- extrReq "required_nodes"
179                 ex_nodes  <- extrReq "relocate_from"
180                 ex_idex   <- mapM (Container.findByName map_n) ex_nodes
181                 return $ Relocate ridx req_nodes (map Node.idx ex_idex)
182           | optype == C.iallocatorModeChgGroup ->
183               do
184                 rl_names <- extrReq "instances"
185                 rl_insts <- mapM (liftM Instance.idx .
186                                   Container.findByName map_i) rl_names
187                 gr_uuids <- extrReq "target_groups"
188                 gr_idxes <- mapM (liftM Group.idx .
189                                   Container.findByName map_g) gr_uuids
190                 return $ ChangeGroup rl_insts gr_idxes
191           | optype == C.iallocatorModeNodeEvac ->
192               do
193                 rl_names <- extrReq "instances"
194                 rl_insts <- mapM (Container.findByName map_i) rl_names
195                 let rl_idx = map Instance.idx rl_insts
196                 rl_mode <- extrReq "evac_mode"
197                 return $ NodeEvacuate rl_idx rl_mode
198
199           | otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
200   return (msgs, Request rqtype cdata)
201
202 -- | Formats the result into a valid IAllocator response message.
203 formatResponse :: Bool     -- ^ Whether the request was successful
204                -> String   -- ^ Information text
205                -> JSValue  -- ^ The JSON encoded result
206                -> String   -- ^ The full JSON-formatted message
207 formatResponse success info result =
208     let
209         e_success = ("success", showJSON success)
210         e_info = ("info", showJSON info)
211         e_result = ("result", result)
212     in encodeStrict $ makeObj [e_success, e_info, e_result]
213
214 -- | Flatten the log of a solution into a string.
215 describeSolution :: Cluster.AllocSolution -> String
216 describeSolution = intercalate ", " . Cluster.asLog
217
218 -- | Convert allocation/relocation results into the result format.
219 formatAllocate :: Instance.List -> Cluster.AllocSolution -> Result IAllocResult
220 formatAllocate il as = do
221   let info = describeSolution as
222   case Cluster.asSolutions as of
223     [] -> fail info
224     (nl, inst, nodes, _):[] ->
225         do
226           let il' = Container.add (Instance.idx inst) inst il
227           return (info, showJSON $ map Node.name nodes, nl, il')
228     _ -> fail "Internal error: multiple allocation solutions"
229
230 -- | Convert a node-evacuation/change group result.
231 formatNodeEvac :: Group.List
232                -> Node.List
233                -> Instance.List
234                -> (Node.List, Instance.List, Cluster.EvacSolution)
235                -> Result IAllocResult
236 formatNodeEvac gl nl il (fin_nl, fin_il, es) =
237     let iname = Instance.name . flip Container.find il
238         nname = Node.name . flip Container.find nl
239         gname = Group.name . flip Container.find gl
240         fes = map (\(idx, msg) -> (iname idx, msg)) $ Cluster.esFailed es
241         mes = map (\(idx, gdx, ndxs) -> (iname idx, gname gdx, map nname ndxs))
242               $ Cluster.esMoved es
243         failed = length fes
244         moved  = length mes
245         info = show failed ++ " instances failed to move and " ++ show moved ++
246                " were moved successfully"
247     in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es), fin_nl, fin_il)
248
249 -- | Runs relocate for a single instance.
250 --
251 -- This is wrapper over the 'Cluster.tryNodeEvac' function that is run
252 -- with a single instance (ours), and further it checks that the
253 -- result it got (in the nodes field) is actually consistent, as
254 -- tryNodeEvac is designed to output primarily an opcode list, not a
255 -- node list.
256 processRelocate :: Group.List      -- ^ The group list
257                 -> Node.List       -- ^ The node list
258                 -> Instance.List   -- ^ The instance list
259                 -> Idx             -- ^ The index of the instance to move
260                 -> Int             -- ^ The number of nodes required
261                 -> [Ndx]           -- ^ Nodes which should not be used
262                 -> Result (Node.List, Instance.List, [Ndx]) -- ^ Solution list
263 processRelocate gl nl il idx 1 exndx = do
264   let orig = Container.find idx il
265       sorig = Instance.sNode orig
266   when (exndx /= [sorig]) $
267        -- FIXME: we can't use the excluded nodes here; the logic is
268        -- already _but only partially_ implemented in tryNodeEvac...
269        fail $ "Unsupported request: excluded nodes not equal to\
270               \ instance's secondary node (" ++ show sorig ++ " versus " ++
271               show exndx ++ ")"
272   (nl', il', esol) <- Cluster.tryNodeEvac gl nl il ChangeSecondary [idx]
273   nodes <- case lookup idx (Cluster.esFailed esol) of
274              Just msg -> fail msg
275              Nothing ->
276                  case lookup idx (map (\(a, _, b) -> (a, b))
277                                   (Cluster.esMoved esol)) of
278                    Nothing ->
279                        fail "Internal error: lost instance idx during move"
280                    Just n -> return n
281   let inst = Container.find idx il'
282       pnode = Instance.pNode inst
283       snode = Instance.sNode inst
284   when (snode == sorig) $
285        fail "Internal error: instance didn't change secondary node?!"
286   when (snode == pnode) $
287        fail "Internal error: selected primary as new secondary?!"
288
289   nodes' <- if (nodes == [pnode, snode])
290             then return [snode] -- only the new secondary is needed
291             else fail $ "Internal error: inconsistent node list (" ++
292                  show nodes ++ ") versus instance nodes (" ++ show pnode ++
293                  "," ++ show snode ++ ")"
294   return (nl', il', nodes')
295
296 processRelocate _ _ _ _ reqn _ =
297   fail $ "Exchange " ++ show reqn ++ " nodes mode is not implemented"
298
299 formatRelocate :: (Node.List, Instance.List, [Ndx])
300                -> Result IAllocResult
301 formatRelocate (nl, il, ndxs) =
302     let nodes = map (`Container.find` nl) ndxs
303         names = map Node.name nodes
304     in Ok ("success", showJSON names, nl, il)
305
306 -- | Process a request and return new node lists.
307 processRequest :: Request -> Result IAllocResult
308 processRequest request =
309   let Request rqtype (ClusterData gl nl il _) = request
310   in case rqtype of
311        Allocate xi reqn ->
312            Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate il
313        Relocate idx reqn exnodes ->
314            processRelocate gl nl il idx reqn exnodes >>= formatRelocate
315        ChangeGroup gdxs idxs ->
316            Cluster.tryChangeGroup gl nl il idxs gdxs >>=
317                   formatNodeEvac gl nl il
318        NodeEvacuate xi mode ->
319            Cluster.tryNodeEvac gl nl il mode xi >>=
320                   formatNodeEvac gl nl il
321
322 -- | Reads the request from the data file(s).
323 readRequest :: Options -> [String] -> IO Request
324 readRequest opts args = do
325   when (null args) $ do
326          hPutStrLn stderr "Error: this program needs an input file."
327          exitWith $ ExitFailure 1
328
329   input_data <- readFile (head args)
330   r1 <- case parseData input_data of
331           Bad err -> do
332             hPutStrLn stderr $ "Error: " ++ err
333             exitWith $ ExitFailure 1
334           Ok (fix_msgs, rq) -> maybeShowWarnings fix_msgs >> return rq
335   (if isJust (optDataFile opts) ||  (not . null . optNodeSim) opts
336    then do
337      cdata <- loadExternalData opts
338      let Request rqt _ = r1
339      return $ Request rqt cdata
340    else return r1)
341
342 -- | Main iallocator pipeline.
343 runIAllocator :: Request -> (Maybe (Node.List, Instance.List), String)
344 runIAllocator request =
345   let (ok, info, result, cdata) =
346           case processRequest request of
347             Ok (msg, r, nl, il) -> (True, "Request successful: " ++ msg, r,
348                                     Just (nl, il))
349             Bad msg -> (False, "Request failed: " ++ msg, JSArray [], Nothing)
350       rstring = formatResponse ok info result
351   in (cdata, rstring)