IAlloc.hs 11.9 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
37
import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
                  makeObj, encodeStrict, decodeStrict,
                  fromJSObject, toJSString)
38
39
40
41
import System (exitWith, ExitCode(..))
import System.IO

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

Iustin Pop's avatar
Iustin Pop committed
53
54
55
56
57
-- | 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
58
parseBaseInstance :: String
59
                  -> JSRecord
Iustin Pop's avatar
Iustin Pop committed
60
61
                  -> Result (String, Instance.Instance)
parseBaseInstance n a = do
62
63
64
65
66
  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"
Iustin Pop's avatar
Iustin Pop committed
67
  let running = "running"
68
  return (n, Instance.create n mem disk vcpus running tags True 0 0)
Iustin Pop's avatar
Iustin Pop committed
69

70
-- | Parses an instance as found in the cluster instance list.
71
72
73
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
74
75
              -> Result (String, Instance.Instance)
parseInstance ktn n a = do
76
  base <- parseBaseInstance n a
77
  nodes <- fromObj a "nodes"
78
79
80
  pnode <- if null nodes
           then Bad $ "empty node list for instance " ++ n
           else readEitherString $ head nodes
81
82
83
84
85
  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
86

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

114
-- | Parses a group as found in the cluster group list.
115
116
parseGroup :: String     -- ^ The group UUID
           -> JSRecord   -- ^ The JSON object
117
118
           -> Result (String, Group.Group)
parseGroup u a = do
119
120
121
122
  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)
123

124
125
parseTargetGroups :: JSRecord      -- ^ The JSON object (request dict)
                  -> Group.List    -- ^ The existing groups
126
127
128
129
130
                  -> 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
131
132
133
-- | 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
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
Iustin Pop's avatar
Iustin Pop committed
138
  -- request parser
139
140
  request <- liftM fromJSObject (extrObj "request")
  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
Iustin Pop's avatar
Iustin Pop committed
144
  let (ktg, gl) = assignIndices gobj
Iustin Pop's avatar
Iustin Pop committed
145
  -- existing node parsing
146
  nlist <- liftM fromJSObject (extrObj "nodes")
Iustin Pop's avatar
Iustin Pop committed
147
148
  nobj <- mapM (\(x,y) ->
                    asJSObject y >>= parseNode ktg x . fromJSObject) nlist
149
  let (ktn, nl) = assignIndices nobj
Iustin Pop's avatar
Iustin Pop committed
150
  -- existing instance parsing
151
  ilist <- extrObj "instances"
Iustin Pop's avatar
Iustin Pop committed
152
  let idata = fromJSObject ilist
153
154
  iobj <- mapM (\(x,y) ->
                    asJSObject y >>= parseInstance ktn x . fromJSObject) idata
155
  let (kti, il) = assignIndices iobj
156
  -- cluster tags
157
  ctags <- extrObj "cluster_tags"
158
  cdata <- mergeData [] [] [] [] (ClusterData gl nl il ctags)
159
  let map_n = cdNodes cdata
160
161
      map_i = cdInstances cdata
      map_g = cdGroups cdata
162
  optype <- extrReq "type"
Iustin Pop's avatar
Iustin Pop committed
163
  rqtype <-
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
      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
186
187
188
189
190
          | 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
191
                rl_mode <-
192
193
194
195
196
197
198
199
200
201
                   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
202
203
204
205
206
207
208
209
210
211
212
213
214
          | 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
215

216
          | otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
217
  return $ Request rqtype cdata
218

219
-- | Format the result
220
221
formatRVal :: RqType -> [Node.AllocElement] -> JSValue
formatRVal _ [] = JSArray []
222

223
formatRVal (Evacuate _) elems =
224
    let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl)
225
               elems
226
227
228
        jsols = map (JSArray . map (JSString . toJSString)) sols
    in JSArray jsols

229
formatRVal _ elems =
230
    let (_, _, nodes, _) = head elems
231
        nodes' = map Node.name nodes
232
233
    in JSArray $ map (JSString . toJSString) nodes'

Iustin Pop's avatar
Iustin Pop committed
234
235
236
-- | Formats the response into a valid IAllocator response message.
formatResponse :: Bool     -- ^ Whether the request was successful
               -> String   -- ^ Information text
237
238
               -> RqType   -- ^ Request type
               -> [Node.AllocElement] -- ^ The resulting allocations
Iustin Pop's avatar
Iustin Pop committed
239
               -> String   -- ^ The JSON-formatted message
240
formatResponse success info rq elems =
241
242
243
    let
        e_success = ("success", JSBool success)
        e_info = ("info", JSString . toJSString $ info)
244
245
        e_result = ("result", formatRVal rq elems)
    in encodeStrict $ makeObj [e_success, e_info, e_result]
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292

processResults :: (Monad m) =>
                  RqType -> Cluster.AllocSolution
               -> m Cluster.AllocSolution
processResults _ (Cluster.AllocSolution { Cluster.asSolutions = [],
                                          Cluster.asLog = msgs }) =
  fail $ intercalate ", " msgs

processResults (Evacuate _) as = return as

processResults _ as =
    case Cluster.asSolutions as of
      _:[] -> return as
      _ -> fail "Internal error: multiple allocation solutions"

-- | Process a request and return new node lists
processRequest :: Request
               -> Result Cluster.AllocSolution
processRequest request =
  let Request rqtype (ClusterData gl nl il _) = request
  in case rqtype of
       Allocate xi reqn -> Cluster.tryMGAlloc gl nl il xi reqn
       Relocate idx reqn exnodes -> Cluster.tryMGReloc gl nl il
                                    idx reqn exnodes
       Evacuate exnodes -> Cluster.tryMGEvac gl nl il exnodes
       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)
293
294
295
296
297
298
299
300
301
302
303
304
305
306

-- | Main iallocator pipeline.
runIAllocator :: Request -> String
runIAllocator request =
  let Request rq _ = request
      sols = processRequest request >>= processResults rq
      (ok, info, rn) =
          case sols of
            Ok as -> (True, "Request successful: " ++
                            intercalate ", " (Cluster.asLog as),
                      Cluster.asSolutions as)
            Bad s -> (False, "Request failed: " ++ s, [])
      resp = formatResponse ok info rq rn
  in resp