Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / HTools / IAlloc.hs @ 255d140d

History | View | Annotate | Download (14 kB)

1
{-| Implementation of the iallocator interface.
2

    
3
-}
4

    
5
{-
6

    
7
Copyright (C) 2009, 2010, 2011, 2012 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
  , loadData
31
  ) where
32

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

    
42
import qualified Ganeti.HTools.Cluster as Cluster
43
import qualified Ganeti.HTools.Container as Container
44
import qualified Ganeti.HTools.Group as Group
45
import qualified Ganeti.HTools.Node as Node
46
import qualified Ganeti.HTools.Instance as Instance
47
import qualified Ganeti.Constants as C
48
import Ganeti.HTools.CLI
49
import Ganeti.HTools.Loader
50
import Ganeti.HTools.JSON
51
import Ganeti.HTools.Types
52

    
53
{-# ANN module "HLint: ignore Eta reduce" #-}
54

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

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

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

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

    
123
-- | Parses a group as found in the cluster group list.
124
parseGroup :: String     -- ^ The group UUID
125
           -> JSRecord   -- ^ The JSON object
126
           -> Result (String, Group.Group)
127
parseGroup u a = do
128
  let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x
129
  name <- extract "name"
130
  apol <- extract "alloc_policy"
131
  ipol <- extract "ipolicy"
132
  return (u, Group.create name u apol ipol)
133

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

    
206
        | otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
207
  return (msgs, Request rqtype cdata)
208

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

    
220
-- | Flatten the log of a solution into a string.
221
describeSolution :: Cluster.AllocSolution -> String
222
describeSolution = intercalate ", " . Cluster.asLog
223

    
224
-- | Convert allocation/relocation results into the result format.
225
formatAllocate :: Instance.List -> Cluster.AllocSolution -> Result IAllocResult
226
formatAllocate il as = do
227
  let info = describeSolution as
228
  case Cluster.asSolution as of
229
    Nothing -> fail info
230
    Just (nl, inst, nodes, _) ->
231
      do
232
        let il' = Container.add (Instance.idx inst) inst il
233
        return (info, showJSON $ map Node.name nodes, nl, il')
234

    
235
-- | Convert a node-evacuation/change group result.
236
formatNodeEvac :: Group.List
237
               -> Node.List
238
               -> Instance.List
239
               -> (Node.List, Instance.List, Cluster.EvacSolution)
240
               -> Result IAllocResult
241
formatNodeEvac gl nl il (fin_nl, fin_il, es) =
242
  let iname = Instance.name . flip Container.find il
243
      nname = Node.name . flip Container.find nl
244
      gname = Group.name . flip Container.find gl
245
      fes = map (\(idx, msg) -> (iname idx, msg)) $ Cluster.esFailed es
246
      mes = map (\(idx, gdx, ndxs) -> (iname idx, gname gdx, map nname ndxs))
247
            $ Cluster.esMoved es
248
      failed = length fes
249
      moved  = length mes
250
      info = show failed ++ " instances failed to move and " ++ show moved ++
251
             " were moved successfully"
252
  in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es), fin_nl, fin_il)
253

    
254
-- | Runs relocate for a single instance.
255
--
256
-- This is wrapper over the 'Cluster.tryNodeEvac' function that is run
257
-- with a single instance (ours), and further it checks that the
258
-- result it got (in the nodes field) is actually consistent, as
259
-- tryNodeEvac is designed to output primarily an opcode list, not a
260
-- node list.
261
processRelocate :: Group.List      -- ^ The group list
262
                -> Node.List       -- ^ The node list
263
                -> Instance.List   -- ^ The instance list
264
                -> Idx             -- ^ The index of the instance to move
265
                -> Int             -- ^ The number of nodes required
266
                -> [Ndx]           -- ^ Nodes which should not be used
267
                -> Result (Node.List, Instance.List, [Ndx]) -- ^ Solution list
268
processRelocate gl nl il idx 1 exndx = do
269
  let orig = Container.find idx il
270
      sorig = Instance.sNode orig
271
  when (exndx /= [sorig]) $
272
       -- FIXME: we can't use the excluded nodes here; the logic is
273
       -- already _but only partially_ implemented in tryNodeEvac...
274
       fail $ "Unsupported request: excluded nodes not equal to\
275
              \ instance's secondary node (" ++ show sorig ++ " versus " ++
276
              show exndx ++ ")"
277
  (nl', il', esol) <- Cluster.tryNodeEvac gl nl il ChangeSecondary [idx]
278
  nodes <- case lookup idx (Cluster.esFailed esol) of
279
             Just msg -> fail msg
280
             Nothing ->
281
                 case lookup idx (map (\(a, _, b) -> (a, b))
282
                                  (Cluster.esMoved esol)) of
283
                   Nothing ->
284
                       fail "Internal error: lost instance idx during move"
285
                   Just n -> return n
286
  let inst = Container.find idx il'
287
      pnode = Instance.pNode inst
288
      snode = Instance.sNode inst
289
  when (snode == sorig) $
290
       fail "Internal error: instance didn't change secondary node?!"
291
  when (snode == pnode) $
292
       fail "Internal error: selected primary as new secondary?!"
293

    
294
  nodes' <- if nodes == [pnode, snode]
295
            then return [snode] -- only the new secondary is needed
296
            else fail $ "Internal error: inconsistent node list (" ++
297
                 show nodes ++ ") versus instance nodes (" ++ show pnode ++
298
                 "," ++ show snode ++ ")"
299
  return (nl', il', nodes')
300

    
301
processRelocate _ _ _ _ reqn _ =
302
  fail $ "Exchange " ++ show reqn ++ " nodes mode is not implemented"
303

    
304
formatRelocate :: (Node.List, Instance.List, [Ndx])
305
               -> Result IAllocResult
306
formatRelocate (nl, il, ndxs) =
307
  let nodes = map (`Container.find` nl) ndxs
308
      names = map Node.name nodes
309
  in Ok ("success", showJSON names, nl, il)
310

    
311
-- | Process a request and return new node lists.
312
processRequest :: Request -> Result IAllocResult
313
processRequest request =
314
  let Request rqtype (ClusterData gl nl il _ _) = request
315
  in case rqtype of
316
       Allocate xi reqn ->
317
         Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate il
318
       Relocate idx reqn exnodes ->
319
         processRelocate gl nl il idx reqn exnodes >>= formatRelocate
320
       ChangeGroup gdxs idxs ->
321
         Cluster.tryChangeGroup gl nl il idxs gdxs >>=
322
                formatNodeEvac gl nl il
323
       NodeEvacuate xi mode ->
324
         Cluster.tryNodeEvac gl nl il mode xi >>=
325
                formatNodeEvac gl nl il
326

    
327
-- | Reads the request from the data file(s).
328
readRequest :: FilePath -> IO Request
329
readRequest fp = do
330
  input_data <- readFile fp
331
  case parseData input_data of
332
    Bad err -> do
333
      hPutStrLn stderr $ "Error: " ++ err
334
      exitWith $ ExitFailure 1
335
    Ok (fix_msgs, rq) -> maybeShowWarnings fix_msgs >> return rq
336

    
337
-- | Main iallocator pipeline.
338
runIAllocator :: Request -> (Maybe (Node.List, Instance.List), String)
339
runIAllocator request =
340
  let (ok, info, result, cdata) =
341
        case processRequest request of
342
          Ok (msg, r, nl, il) -> (True, "Request successful: " ++ msg, r,
343
                                  Just (nl, il))
344
          Bad msg -> (False, "Request failed: " ++ msg, JSArray [], Nothing)
345
      rstring = formatResponse ok info result
346
  in (cdata, rstring)
347

    
348
-- | Load the data from an iallocation request file
349
loadData :: FilePath -- ^ The path to the file
350
         -> IO (Result ClusterData)
351
loadData fp = do
352
  Request _ cdata <- readRequest fp
353
  return $ Ok cdata