IAlloc.hs 11.8 KB
Newer Older
1
2
3
4
{-| Implementation of the iallocator interface.

-}

Iustin Pop's avatar
Iustin Pop committed
5
6
{-

7
Copyright (C) 2009, 2010, 2011 Google Inc.
Iustin Pop's avatar
Iustin Pop committed
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

26
module Ganeti.HTools.IAlloc
27
28
    ( readRequest
    , runIAllocator
29
30
31
    ) where

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

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

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

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

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

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

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

127
128
parseTargetGroups :: JSRecord      -- ^ The JSON object (request dict)
                  -> Group.List    -- ^ The existing groups
129
130
131
132
133
                  -> Result [Gdx]
parseTargetGroups req map_g = do
  group_uuids <- fromObjWithDefault req "target_groups" []
  mapM (liftM Group.idx . Container.findByName map_g) group_uuids

Iustin Pop's avatar
Iustin Pop committed
134
135
136
-- | Top-level parser.
parseData :: String         -- ^ The JSON message as received from Ganeti
          -> Result Request -- ^ A (possible valid) request
Iustin Pop's avatar
Iustin Pop committed
137
parseData body = do
138
  decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
139
  let obj = fromJSObject decoded
140
      extrObj x = tryFromObj "invalid iallocator message" obj x
Iustin Pop's avatar
Iustin Pop committed
141
  -- request parser
142
143
  request <- liftM fromJSObject (extrObj "request")
  let extrReq x = tryFromObj "invalid request dict" request x
144
  -- existing group parsing
145
  glist <- liftM fromJSObject (extrObj "nodegroups")
146
  gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist
Iustin Pop's avatar
Iustin Pop committed
147
  let (ktg, gl) = assignIndices gobj
Iustin Pop's avatar
Iustin Pop committed
148
  -- existing node parsing
149
  nlist <- liftM fromJSObject (extrObj "nodes")
Iustin Pop's avatar
Iustin Pop committed
150
151
  nobj <- mapM (\(x,y) ->
                    asJSObject y >>= parseNode ktg x . fromJSObject) nlist
152
  let (ktn, nl) = assignIndices nobj
Iustin Pop's avatar
Iustin Pop committed
153
  -- existing instance parsing
154
  ilist <- extrObj "instances"
Iustin Pop's avatar
Iustin Pop committed
155
  let idata = fromJSObject ilist
156
157
  iobj <- mapM (\(x,y) ->
                    asJSObject y >>= parseInstance ktn x . fromJSObject) idata
158
  let (kti, il) = assignIndices iobj
159
  -- cluster tags
160
  ctags <- extrObj "cluster_tags"
161
  cdata <- mergeData [] [] [] [] (ClusterData gl nl il ctags)
162
  let map_n = cdNodes cdata
163
164
      map_i = cdInstances cdata
      map_g = cdGroups cdata
165
  optype <- extrReq "type"
Iustin Pop's avatar
Iustin Pop committed
166
  rqtype <-
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
      case () of
        _ | optype == C.iallocatorModeAlloc ->
              do
                rname     <- extrReq "name"
                req_nodes <- extrReq "required_nodes"
                inew      <- parseBaseInstance rname request
                let io = snd inew
                return $ Allocate io req_nodes
          | optype == C.iallocatorModeReloc ->
              do
                rname     <- extrReq "name"
                ridx      <- lookupInstance kti rname
                req_nodes <- extrReq "required_nodes"
                ex_nodes  <- extrReq "relocate_from"
                ex_idex   <- mapM (Container.findByName map_n) ex_nodes
                return $ Relocate ridx req_nodes (map Node.idx ex_idex)
          | optype == C.iallocatorModeMevac ->
              do
                ex_names <- extrReq "evac_nodes"
                ex_nodes <- mapM (Container.findByName map_n) ex_names
                let ex_ndx = map Node.idx ex_nodes
                return $ Evacuate ex_ndx
189
190
191
192
193
          | optype == C.iallocatorModeMreloc ->
              do
                rl_names <- extrReq "instances"
                rl_insts <- mapM (Container.findByName map_i) rl_names
                let rl_idx = map Instance.idx rl_insts
Iustin Pop's avatar
Iustin Pop committed
194
                rl_mode <-
195
196
197
198
199
200
201
202
203
204
                   case extrReq "reloc_mode" of
                     Ok s | s == C.iallocatorMrelocKeep -> return KeepGroup
                          | s == C.iallocatorMrelocChange ->
                              do
                                tg_groups <- parseTargetGroups request map_g
                                return $ ChangeGroup tg_groups
                          | s == C.iallocatorMrelocAny -> return AnyGroup
                          | otherwise -> Bad $ "Invalid relocate mode " ++ s
                     Bad x -> Bad x
                return $ MultiReloc rl_idx rl_mode
205
206
207
208
209
210
211
212
213
214
215
216
217
          | optype == C.iallocatorModeNodeEvac ->
              do
                rl_names <- extrReq "instances"
                rl_insts <- mapM (Container.findByName map_i) rl_names
                let rl_idx = map Instance.idx rl_insts
                rl_mode <-
                   case extrReq "evac_mode" of
                     Ok s | s == C.iallocatorNevacAll -> return ChangeAll
                          | s == C.iallocatorNevacPri -> return ChangePrimary
                          | s == C.iallocatorNevacSec -> return ChangeSecondary
                          | otherwise -> Bad $ "Invalid evacuate mode " ++ s
                     Bad x -> Bad x
                return $ NodeEvacuate rl_idx rl_mode
218

219
          | otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
220
  return $ Request rqtype cdata
221

222
-- | Formats the result into a valid IAllocator response message.
Iustin Pop's avatar
Iustin Pop committed
223
224
formatResponse :: Bool     -- ^ Whether the request was successful
               -> String   -- ^ Information text
225
226
227
               -> JSValue  -- ^ The JSON encoded result
               -> String   -- ^ The full JSON-formatted message
formatResponse success info result =
228
    let
229
230
        e_success = ("success", showJSON success)
        e_info = ("info", showJSON info)
231
        e_result = ("result", result)
232
    in encodeStrict $ makeObj [e_success, e_info, e_result]
233

234
235
236
-- | Flatten the log of a solution into a string.
describeSolution :: Cluster.AllocSolution -> String
describeSolution = intercalate ", " . Cluster.asLog
237

238
239
240
241
242
243
244
245
-- | Convert evacuation results into the result format.
formatEvacuate :: Cluster.AllocSolution -> Result IAllocResult
formatEvacuate as = do
  let info = describeSolution as
      elems = Cluster.asSolutions as
  when (null elems) $ fail info
  let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl)
             elems
246
  return (info, showJSON sols)
247

248
249
250
251
252
253
-- | Convert allocation/relocation results into the result format.
formatAllocate :: Cluster.AllocSolution -> Result IAllocResult
formatAllocate as = do
  let info = describeSolution as
  case Cluster.asSolutions as of
    [] -> fail info
254
    (_, _, nodes, _):[] -> return (info, showJSON $ map (Node.name) nodes)
255
    _ -> fail "Internal error: multiple allocation solutions"
256
257

-- | Process a request and return new node lists
258
processRequest :: Request -> Result IAllocResult
259
260
261
processRequest request =
  let Request rqtype (ClusterData gl nl il _) = request
  in case rqtype of
262
263
264
265
266
267
       Allocate xi reqn ->
           Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate
       Relocate idx reqn exnodes ->
           Cluster.tryMGReloc gl nl il idx reqn exnodes >>= formatAllocate
       Evacuate exnodes ->
           Cluster.tryMGEvac gl nl il exnodes >>= formatEvacuate
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
       MultiReloc _ _ -> fail "multi-reloc not handled"
       NodeEvacuate _ _ -> fail "node-evacuate not handled"

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

  input_data <- readFile (head args)
  r1 <- case parseData input_data of
          Bad err -> do
            hPutStrLn stderr $ "Error: " ++ err
            exitWith $ ExitFailure 1
          Ok rq -> return rq
  (if isJust (optDataFile opts) ||  (not . null . optNodeSim) opts
   then do
     cdata <- loadExternalData opts
     let Request rqt _ = r1
     return $ Request rqt cdata
   else return r1)
290
291
292
293

-- | Main iallocator pipeline.
runIAllocator :: Request -> String
runIAllocator request =
294
295
296
297
298
  let (ok, info, result) =
          case processRequest request of
            Ok (msg, r) -> (True, "Request successful: " ++ msg, r)
            Bad msg -> (False, "Request failed: " ++ msg, JSArray [])
  in  formatResponse ok info result