Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / HTools / IAlloc.hs @ 6804faa0

History | View | Annotate | Download (14.2 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.asSolutions as of
224
    [] -> fail info
225
    (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
    _ -> fail "Internal error: multiple allocation solutions"
230

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

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

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

    
297
processRelocate _ _ _ _ reqn _ =
298
  fail $ "Exchange " ++ show reqn ++ " nodes mode is not implemented"
299

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

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

    
323
-- | Reads the request from the data file(s).
324
readRequest :: Options -> [String] -> IO Request
325
readRequest opts args = do
326
  when (null args) $ do
327
         hPutStrLn stderr "Error: this program needs an input file."
328
         exitWith $ ExitFailure 1
329

    
330
  input_data <- readFile (head args)
331
  r1 <- 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
  (if isJust (optDataFile opts) ||  (not . null . optNodeSim) opts
337
   then do
338
     cdata <- loadExternalData opts
339
     let Request rqt _ = r1
340
     return $ Request rqt cdata
341
   else return r1)
342

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