Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / HTools / IAlloc.hs @ 7345b69b

History | View | Annotate | Download (13.9 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.Exit
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
  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 e_success = ("success", showJSON success)
209
      e_info = ("info", showJSON info)
210
      e_result = ("result", result)
211
  in encodeStrict $ makeObj [e_success, e_info, e_result]
212

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

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

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

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

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

    
294
processRelocate _ _ _ _ reqn _ =
295
  fail $ "Exchange " ++ show reqn ++ " nodes mode is not implemented"
296

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

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

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

    
327
  input_data <- readFile (head args)
328
  r1 <- case parseData input_data of
329
          Bad err -> do
330
            hPutStrLn stderr $ "Error: " ++ err
331
            exitWith $ ExitFailure 1
332
          Ok (fix_msgs, rq) -> maybeShowWarnings fix_msgs >> return rq
333
  (if isJust (optDataFile opts) ||  (not . null . optNodeSim) opts
334
   then do
335
     cdata <- loadExternalData opts
336
     let Request rqt _ = r1
337
     return $ Request rqt cdata
338
   else return r1)
339

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