Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / HTools / IAlloc.hs @ 129734d3

History | View | Annotate | Download (14.1 kB)

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
    , processRelocate
30
    ) where
31

    
32
import Data.Either ()
33
import Data.Maybe (fromMaybe, isJust)
34
import Data.List
35
import Control.Monad
36
import Text.JSON (JSObject, JSValue(JSArray),
37
                  makeObj, encodeStrict, decodeStrict, fromJSObject, showJSON)
38
import System (exitWith, ExitCode(..))
39
import System.IO
40

    
41
import qualified Ganeti.HTools.Cluster as Cluster
42
import qualified Ganeti.HTools.Container as Container
43
import qualified Ganeti.HTools.Group as Group
44
import qualified Ganeti.HTools.Node as Node
45
import qualified Ganeti.HTools.Instance as Instance
46
import qualified Ganeti.Constants as C
47
import Ganeti.HTools.CLI
48
import Ganeti.HTools.Loader
49
import Ganeti.HTools.ExtLoader (loadExternalData)
50
import Ganeti.HTools.Utils
51
import Ganeti.HTools.Types
52

    
53
-- | Type alias for the result of an IAllocator call.
54
type IAllocResult = (String, JSValue, Node.List, Instance.List)
55

    
56
-- | Parse the basic specifications of an instance.
57
--
58
-- Instances in the cluster instance list and the instance in an
59
-- 'Allocate' request share some common properties, which are read by
60
-- this function.
61
parseBaseInstance :: String
62
                  -> JSRecord
63
                  -> Result (String, Instance.Instance)
64
parseBaseInstance n a = do
65
  let extract x = tryFromObj ("invalid data for instance '" ++ n ++ "'") a x
66
  disk  <- extract "disk_space_total"
67
  mem   <- extract "memory"
68
  vcpus <- extract "vcpus"
69
  tags  <- extract "tags"
70
  dt    <- extract "disk_template"
71
  let running = "running"
72
  return (n, Instance.create n mem disk vcpus running tags True 0 0 dt)
73

    
74
-- | Parses an instance as found in the cluster instance list.
75
parseInstance :: NameAssoc -- ^ The node name-to-index association list
76
              -> String    -- ^ The name of the instance
77
              -> JSRecord  -- ^ The JSON object
78
              -> Result (String, Instance.Instance)
79
parseInstance ktn n a = do
80
  base <- parseBaseInstance n a
81
  nodes <- fromObj a "nodes"
82
  pnode <- if null nodes
83
           then Bad $ "empty node list for instance " ++ n
84
           else readEitherString $ head nodes
85
  pidx <- lookupNode ktn n pnode
86
  let snodes = tail nodes
87
  sidx <- (if null snodes then return Node.noSecondary
88
           else readEitherString (head snodes) >>= lookupNode ktn n)
89
  return (n, Instance.setBoth (snd base) pidx sidx)
90

    
91
-- | Parses a node as found in the cluster node list.
92
parseNode :: NameAssoc   -- ^ The group association
93
          -> String      -- ^ The node's name
94
          -> JSRecord    -- ^ The JSON object
95
          -> Result (String, Node.Node)
96
parseNode ktg n a = do
97
  let desc = "invalid data for node '" ++ n ++ "'"
98
      extract x = tryFromObj desc a x
99
  offline <- extract "offline"
100
  drained <- extract "drained"
101
  guuid   <- extract "group"
102
  vm_capable  <- annotateResult desc $ maybeFromObj a "vm_capable"
103
  let vm_capable' = fromMaybe True vm_capable
104
  gidx <- lookupGroup ktg n guuid
105
  node <- (if offline || drained || not vm_capable'
106
           then return $ Node.create n 0 0 0 0 0 0 True gidx
107
           else do
108
             mtotal <- extract "total_memory"
109
             mnode  <- extract "reserved_memory"
110
             mfree  <- extract "free_memory"
111
             dtotal <- extract "total_disk"
112
             dfree  <- extract "free_disk"
113
             ctotal <- extract "total_cpus"
114
             return $ Node.create n mtotal mnode mfree
115
                    dtotal dfree ctotal False gidx)
116
  return (n, node)
117

    
118
-- | Parses a group as found in the cluster group list.
119
parseGroup :: String     -- ^ The group UUID
120
           -> JSRecord   -- ^ The JSON object
121
           -> Result (String, Group.Group)
122
parseGroup u a = do
123
  let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x
124
  name <- extract "name"
125
  apol <- extract "alloc_policy"
126
  return (u, Group.create name u apol)
127

    
128
-- | Top-level parser.
129
--
130
-- The result is a tuple of eventual warning messages and the parsed
131
-- request; if parsing the input data fails, we'll return a 'Bad'
132
-- value.
133
parseData :: String -- ^ The JSON message as received from Ganeti
134
          -> Result ([String], Request) -- ^ Result tuple
135
parseData body = do
136
  decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
137
  let obj = fromJSObject decoded
138
      extrObj x = tryFromObj "invalid iallocator message" obj x
139
  -- request parser
140
  request <- liftM fromJSObject (extrObj "request")
141
  let extrReq x = tryFromObj "invalid request dict" request x
142
  -- existing group parsing
143
  glist <- liftM fromJSObject (extrObj "nodegroups")
144
  gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist
145
  let (ktg, gl) = assignIndices gobj
146
  -- existing node parsing
147
  nlist <- liftM fromJSObject (extrObj "nodes")
148
  nobj <- mapM (\(x,y) ->
149
                    asJSObject y >>= parseNode ktg x . fromJSObject) nlist
150
  let (ktn, nl) = assignIndices nobj
151
  -- existing instance parsing
152
  ilist <- extrObj "instances"
153
  let idata = fromJSObject ilist
154
  iobj <- mapM (\(x,y) ->
155
                    asJSObject y >>= parseInstance ktn x . fromJSObject) idata
156
  let (kti, il) = assignIndices iobj
157
  -- cluster tags
158
  ctags <- extrObj "cluster_tags"
159
  cdata1 <- mergeData [] [] [] [] (ClusterData gl nl il ctags)
160
  let (msgs, fix_nl) = checkData (cdNodes cdata1) (cdInstances cdata1)
161
      cdata = cdata1 { cdNodes = fix_nl }
162
      map_n = cdNodes cdata
163
      map_i = cdInstances cdata
164
      map_g = cdGroups cdata
165
  optype <- extrReq "type"
166
  rqtype <-
167
      case () of
168
        _ | optype == C.iallocatorModeAlloc ->
169
              do
170
                rname     <- extrReq "name"
171
                req_nodes <- extrReq "required_nodes"
172
                inew      <- parseBaseInstance rname request
173
                let io = snd inew
174
                return $ Allocate io req_nodes
175
          | optype == C.iallocatorModeReloc ->
176
              do
177
                rname     <- extrReq "name"
178
                ridx      <- lookupInstance kti rname
179
                req_nodes <- extrReq "required_nodes"
180
                ex_nodes  <- extrReq "relocate_from"
181
                ex_idex   <- mapM (Container.findByName map_n) ex_nodes
182
                return $ Relocate ridx req_nodes (map Node.idx ex_idex)
183
          | optype == C.iallocatorModeChgGroup ->
184
              do
185
                rl_names <- extrReq "instances"
186
                rl_insts <- mapM (liftM Instance.idx .
187
                                  Container.findByName map_i) rl_names
188
                gr_uuids <- extrReq "target_groups"
189
                gr_idxes <- mapM (liftM Group.idx .
190
                                  Container.findByName map_g) gr_uuids
191
                return $ ChangeGroup rl_insts gr_idxes
192
          | optype == C.iallocatorModeNodeEvac ->
193
              do
194
                rl_names <- extrReq "instances"
195
                rl_insts <- mapM (Container.findByName map_i) rl_names
196
                let rl_idx = map Instance.idx rl_insts
197
                rl_mode <- extrReq "evac_mode"
198
                return $ NodeEvacuate rl_idx rl_mode
199

    
200
          | otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
201
  return (msgs, Request rqtype cdata)
202

    
203
-- | Formats the result into a valid IAllocator response message.
204
formatResponse :: Bool     -- ^ Whether the request was successful
205
               -> String   -- ^ Information text
206
               -> JSValue  -- ^ The JSON encoded result
207
               -> String   -- ^ The full JSON-formatted message
208
formatResponse success info result =
209
    let
210
        e_success = ("success", showJSON success)
211
        e_info = ("info", showJSON info)
212
        e_result = ("result", result)
213
    in encodeStrict $ makeObj [e_success, e_info, e_result]
214

    
215
-- | Flatten the log of a solution into a string.
216
describeSolution :: Cluster.AllocSolution -> String
217
describeSolution = intercalate ", " . Cluster.asLog
218

    
219
-- | Convert allocation/relocation results into the result format.
220
formatAllocate :: Instance.List -> Cluster.AllocSolution -> Result IAllocResult
221
formatAllocate il as = do
222
  let info = describeSolution as
223
  case Cluster.asSolution as of
224
    Nothing -> fail info
225
    Just (nl, inst, nodes, _) ->
226
        do
227
          let il' = Container.add (Instance.idx inst) inst il
228
          return (info, showJSON $ map Node.name nodes, nl, il')
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)