code.grnet.gr Git - ganeti-local/blob - htools/Ganeti/HTools/IAlloc.hs

   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, isJust, fromJust)
  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 Ganeti.BasicTypes
  43 import qualified Ganeti.HTools.Cluster as Cluster
  44 import qualified Ganeti.HTools.Container as Container
  45 import qualified Ganeti.HTools.Group as Group
  46 import qualified Ganeti.HTools.Node as Node
  47 import qualified Ganeti.HTools.Instance as Instance
  48 import qualified Ganeti.Constants as C
  49 import Ganeti.HTools.CLI
  50 import Ganeti.HTools.Loader
  51 import Ganeti.HTools.Types
  52 import Ganeti.JSON
  53
  54 {-# ANN module "HLint: ignore Eta reduce" #-}
  55
  56 -- | Type alias for the result of an IAllocator call.
  57 type IAllocResult = (String, JSValue, Node.List, Instance.List)
  58
  59 -- | Parse the basic specifications of an instance.
  60 --
  61 -- Instances in the cluster instance list and the instance in an
  62 -- 'Allocate' request share some common properties, which are read by
  63 -- this function.
  64 parseBaseInstance :: String
  65                   -> JSRecord
  66                   -> Result (String, Instance.Instance)
  67 parseBaseInstance n a = do
  68   let extract x = tryFromObj ("invalid data for instance '" ++ n ++ "'") a x
  69   disk  <- extract "disk_space_total"
  70   mem   <- extract "memory"
  71   vcpus <- extract "vcpus"
  72   tags  <- extract "tags"
  73   dt    <- extract "disk_template"
  74   su    <- extract "spindle_use"
  75   return (n, Instance.create n mem disk vcpus Running tags True 0 0 dt su)
  76
  77 -- | Parses an instance as found in the cluster instance list.
  78 parseInstance :: NameAssoc -- ^ The node name-to-index association list
  79               -> String    -- ^ The name of the instance
  80               -> JSRecord  -- ^ The JSON object
  81               -> Result (String, Instance.Instance)
  82 parseInstance ktn n a = do
  83   base <- parseBaseInstance n a
  84   nodes <- fromObj a "nodes"
  85   pnode <- if null nodes
  86            then Bad $ "empty node list for instance " ++ n
  87            else readEitherString $ head nodes
  88   pidx <- lookupNode ktn n pnode
  89   let snodes = tail nodes
  90   sidx <- if null snodes
  91             then return Node.noSecondary
  92             else readEitherString (head snodes) >>= lookupNode ktn n
  93   return (n, Instance.setBoth (snd base) pidx sidx)
  94
  95 -- | Parses a node as found in the cluster node list.
  96 parseNode :: NameAssoc   -- ^ The group association
  97           -> String      -- ^ The node's name
  98           -> JSRecord    -- ^ The JSON object
  99           -> Result (String, Node.Node)
 100 parseNode ktg n a = do
 101   let desc = "invalid data for node '" ++ n ++ "'"
 102       extract x = tryFromObj desc a x
 103   offline <- extract "offline"
 104   drained <- extract "drained"
 105   guuid   <- extract "group"
 106   vm_capable  <- annotateResult desc $ maybeFromObj a "vm_capable"
 107   let vm_capable' = fromMaybe True vm_capable
 108   gidx <- lookupGroup ktg n guuid
 109   node <- if offline || drained || not vm_capable'
 110             then return $ Node.create n 0 0 0 0 0 0 True 0 gidx
 111             else do
 112               mtotal <- extract "total_memory"
 113               mnode  <- extract "reserved_memory"
 114               mfree  <- extract "free_memory"
 115               dtotal <- extract "total_disk"
 116               dfree  <- extract "free_disk"
 117               ctotal <- extract "total_cpus"
 118               ndparams <- extract "ndparams" >>= asJSObject
 119               spindles <- tryFromObj desc (fromJSObject ndparams)
 120                           "spindle_count"
 121               return $ Node.create n mtotal mnode mfree
 122                      dtotal dfree ctotal False spindles gidx
 123   return (n, node)
 124
 125 -- | Parses a group as found in the cluster group list.
 126 parseGroup :: String     -- ^ The group UUID
 127            -> JSRecord   -- ^ The JSON object
 128            -> Result (String, Group.Group)
 129 parseGroup u a = do
 130   let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x
 131   name <- extract "name"
 132   apol <- extract "alloc_policy"
 133   ipol <- extract "ipolicy"
 134   return (u, Group.create name u apol ipol)
 135
 136 -- | Top-level parser.
 137 --
 138 -- The result is a tuple of eventual warning messages and the parsed
 139 -- request; if parsing the input data fails, we'll return a 'Bad'
 140 -- value.
 141 parseData :: String -- ^ The JSON message as received from Ganeti
 142           -> Result ([String], Request) -- ^ Result tuple
 143 parseData body = do
 144   decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
 145   let obj = fromJSObject decoded
 146       extrObj x = tryFromObj "invalid iallocator message" obj x
 147   -- request parser
 148   request <- liftM fromJSObject (extrObj "request")
 149   let extrFromReq r x = tryFromObj "invalid request dict" r x
 150   let extrReq x = extrFromReq request x
 151   -- existing group parsing
 152   glist <- liftM fromJSObject (extrObj "nodegroups")
 153   gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist
 154   let (ktg, gl) = assignIndices gobj
 155   -- existing node parsing
 156   nlist <- liftM fromJSObject (extrObj "nodes")
 157   nobj <- mapM (\(x,y) ->
 158                     asJSObject y >>= parseNode ktg x . fromJSObject) nlist
 159   let (ktn, nl) = assignIndices nobj
 160   -- existing instance parsing
 161   ilist <- extrObj "instances"
 162   let idata = fromJSObject ilist
 163   iobj <- mapM (\(x,y) ->
 164                     asJSObject y >>= parseInstance ktn x . fromJSObject) idata
 165   let (kti, il) = assignIndices iobj
 166   -- cluster tags
 167   ctags <- extrObj "cluster_tags"
 168   cdata1 <- mergeData [] [] [] [] (ClusterData gl nl il ctags defIPolicy)
 169   let (msgs, fix_nl) = checkData (cdNodes cdata1) (cdInstances cdata1)
 170       cdata = cdata1 { cdNodes = fix_nl }
 171       map_n = cdNodes cdata
 172       map_i = cdInstances cdata
 173       map_g = cdGroups cdata
 174   optype <- extrReq "type"
 175   rqtype <-
 176     case () of
 177       _ | optype == C.iallocatorModeAlloc ->
 178             do
 179               rname     <- extrReq "name"
 180               req_nodes <- extrReq "required_nodes"
 181               inew      <- parseBaseInstance rname request
 182               let io = snd inew
 183               return $ Allocate io req_nodes
 184         | optype == C.iallocatorModeReloc ->
 185             do
 186               rname     <- extrReq "name"
 187               ridx      <- lookupInstance kti rname
 188               req_nodes <- extrReq "required_nodes"
 189               ex_nodes  <- extrReq "relocate_from"
 190               ex_idex   <- mapM (Container.findByName map_n) ex_nodes
 191               return $ Relocate ridx req_nodes (map Node.idx ex_idex)
 192         | optype == C.iallocatorModeChgGroup ->
 193             do
 194               rl_names <- extrReq "instances"
 195               rl_insts <- mapM (liftM Instance.idx .
 196                                 Container.findByName map_i) rl_names
 197               gr_uuids <- extrReq "target_groups"
 198               gr_idxes <- mapM (liftM Group.idx .
 199                                 Container.findByName map_g) gr_uuids
 200               return $ ChangeGroup rl_insts gr_idxes
 201         | optype == C.iallocatorModeNodeEvac ->
 202             do
 203               rl_names <- extrReq "instances"
 204               rl_insts <- mapM (Container.findByName map_i) rl_names
 205               let rl_idx = map Instance.idx rl_insts
 206               rl_mode <- extrReq "evac_mode"
 207               return $ NodeEvacuate rl_idx rl_mode
 208         | optype == C.iallocatorModeMultiAlloc ->
 209             do
 210               arry <- extrReq "instances" :: Result [JSObject JSValue]
 211               let inst_reqs = map fromJSObject arry
 212               prqs <- mapM (\r ->
 213                                do
 214                                  rname     <- extrFromReq r "name"
 215                                  req_nodes <- extrFromReq r "required_nodes"
 216                                  inew      <- parseBaseInstance rname r
 217                                  let io = snd inew
 218                                  return (io, req_nodes)) inst_reqs
 219               return $ MultiAllocate prqs
 220         | otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
 221   return (msgs, Request rqtype cdata)
 222
 223 -- | Formats the result into a valid IAllocator response message.
 224 formatResponse :: Bool     -- ^ Whether the request was successful
 225                -> String   -- ^ Information text
 226                -> JSValue  -- ^ The JSON encoded result
 227                -> String   -- ^ The full JSON-formatted message
 228 formatResponse success info result =
 229   let e_success = ("success", showJSON success)
 230       e_info = ("info", showJSON info)
 231       e_result = ("result", result)
 232   in encodeStrict $ makeObj [e_success, e_info, e_result]
 233
 234 -- | Flatten the log of a solution into a string.
 235 describeSolution :: Cluster.AllocSolution -> String
 236 describeSolution = intercalate ", " . Cluster.asLog
 237
 238 -- | Convert allocation/relocation results into the result format.
 239 formatAllocate :: Instance.List -> Cluster.AllocSolution -> Result IAllocResult
 240 formatAllocate il as = do
 241   let info = describeSolution as
 242   case Cluster.asSolution as of
 243     Nothing -> fail info
 244     Just (nl, inst, nodes, _) ->
 245       do
 246         let il' = Container.add (Instance.idx inst) inst il
 247         return (info, showJSON $ map Node.name nodes, nl, il')
 248
 249 -- | Convert multi allocation results into the result format.
 250 formatMultiAlloc :: (Node.List, Instance.List, Cluster.AllocSolutionList)
 251                  -> Result IAllocResult
 252 formatMultiAlloc (fin_nl, fin_il, ars) =
 253   let rars = reverse ars
 254       (allocated, failed) = partition (isJust . Cluster.asSolution . snd) rars
 255       aars = map (\(_, ar) ->
 256                      let (_, inst, nodes, _) = fromJust $ Cluster.asSolution ar
 257                          iname = Instance.name inst
 258                          nnames = map Node.name nodes
 259                      in (iname, nnames)) allocated
 260       fars = map (\(inst, ar) ->
 261                      let iname = Instance.name inst
 262                      in (iname, describeSolution ar)) failed
 263       info = show (length failed) ++ " instances failed to allocate and " ++
 264              show (length allocated) ++ " were allocated successfully"
 265   in return (info, showJSON (aars, fars), fin_nl, fin_il)
 266
 267 -- | Convert a node-evacuation/change group result.
 268 formatNodeEvac :: Group.List
 269                -> Node.List
 270                -> Instance.List
 271                -> (Node.List, Instance.List, Cluster.EvacSolution)
 272                -> Result IAllocResult
 273 formatNodeEvac gl nl il (fin_nl, fin_il, es) =
 274   let iname = Instance.name . flip Container.find il
 275       nname = Node.name . flip Container.find nl
 276       gname = Group.name . flip Container.find gl
 277       fes = map (\(idx, msg) -> (iname idx, msg)) $ Cluster.esFailed es
 278       mes = map (\(idx, gdx, ndxs) -> (iname idx, gname gdx, map nname ndxs))
 279             $ Cluster.esMoved es
 280       failed = length fes
 281       moved  = length mes
 282       info = show failed ++ " instances failed to move and " ++ show moved ++
 283              " were moved successfully"
 284   in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es), fin_nl, fin_il)
 285
 286 -- | Runs relocate for a single instance.
 287 --
 288 -- This is wrapper over the 'Cluster.tryNodeEvac' function that is run
 289 -- with a single instance (ours), and further it checks that the
 290 -- result it got (in the nodes field) is actually consistent, as
 291 -- tryNodeEvac is designed to output primarily an opcode list, not a
 292 -- node list.
 293 processRelocate :: Group.List      -- ^ The group list
 294                 -> Node.List       -- ^ The node list
 295                 -> Instance.List   -- ^ The instance list
 296                 -> Idx             -- ^ The index of the instance to move
 297                 -> Int             -- ^ The number of nodes required
 298                 -> [Ndx]           -- ^ Nodes which should not be used
 299                 -> Result (Node.List, Instance.List, [Ndx]) -- ^ Solution list
 300 processRelocate gl nl il idx 1 exndx = do
 301   let orig = Container.find idx il
 302       sorig = Instance.sNode orig
 303       porig = Instance.pNode orig
 304       mir_type = Instance.mirrorType orig
 305   (exp_node, node_type, reloc_type) <-
 306     case mir_type of
 307       MirrorNone -> fail "Can't relocate non-mirrored instances"
 308       MirrorInternal -> return (sorig, "secondary", ChangeSecondary)
 309       MirrorExternal -> return (porig, "primary", ChangePrimary)
 310   when (exndx /= [exp_node]) .
 311        -- FIXME: we can't use the excluded nodes here; the logic is
 312        -- already _but only partially_ implemented in tryNodeEvac...
 313        fail $ "Unsupported request: excluded nodes not equal to\
 314               \ instance's " ++  node_type ++ "(" ++ show exp_node
 315               ++ " versus " ++ show exndx ++ ")"
 316   (nl', il', esol) <- Cluster.tryNodeEvac gl nl il reloc_type [idx]
 317   nodes <- case lookup idx (Cluster.esFailed esol) of
 318              Just msg -> fail msg
 319              Nothing ->
 320                  case lookup idx (map (\(a, _, b) -> (a, b))
 321                                   (Cluster.esMoved esol)) of
 322                    Nothing ->
 323                        fail "Internal error: lost instance idx during move"
 324                    Just n -> return n
 325   let inst = Container.find idx il'
 326       pnode = Instance.pNode inst
 327       snode = Instance.sNode inst
 328   nodes' <-
 329     case mir_type of
 330       MirrorNone -> fail "Internal error: mirror type none after relocation?!"
 331       MirrorInternal ->
 332         do
 333           when (snode == sorig) $
 334                fail "Internal error: instance didn't change secondary node?!"
 335           when (snode == pnode) $
 336                fail "Internal error: selected primary as new secondary?!"
 337           if nodes == [pnode, snode]
 338             then return [snode] -- only the new secondary is needed
 339             else fail $ "Internal error: inconsistent node list (" ++
 340                  show nodes ++ ") versus instance nodes (" ++ show pnode ++
 341                  "," ++ show snode ++ ")"
 342       MirrorExternal ->
 343         do
 344           when (pnode == porig) $
 345                fail "Internal error: instance didn't change primary node?!"
 346           if nodes == [pnode]
 347             then return nodes
 348             else fail $ "Internal error: inconsistent node list (" ++
 349                  show nodes ++ ") versus instance node (" ++ show pnode ++ ")"
 350   return (nl', il', nodes')
 351
 352 processRelocate _ _ _ _ reqn _ =
 353   fail $ "Exchange " ++ show reqn ++ " nodes mode is not implemented"
 354
 355 formatRelocate :: (Node.List, Instance.List, [Ndx])
 356                -> Result IAllocResult
 357 formatRelocate (nl, il, ndxs) =
 358   let nodes = map (`Container.find` nl) ndxs
 359       names = map Node.name nodes
 360   in Ok ("success", showJSON names, nl, il)
 361
 362 -- | Process a request and return new node lists.
 363 processRequest :: Request -> Result IAllocResult
 364 processRequest request =
 365   let Request rqtype (ClusterData gl nl il _ _) = request
 366   in case rqtype of
 367        Allocate xi reqn ->
 368          Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate il
 369        Relocate idx reqn exnodes ->
 370          processRelocate gl nl il idx reqn exnodes >>= formatRelocate
 371        ChangeGroup gdxs idxs ->
 372          Cluster.tryChangeGroup gl nl il idxs gdxs >>=
 373                 formatNodeEvac gl nl il
 374        NodeEvacuate xi mode ->
 375          Cluster.tryNodeEvac gl nl il mode xi >>=
 376                 formatNodeEvac gl nl il
 377        MultiAllocate xies ->
 378          Cluster.allocList gl nl il xies [] >>= formatMultiAlloc
 379
 380 -- | Reads the request from the data file(s).
 381 readRequest :: FilePath -> IO Request
 382 readRequest fp = do
 383   input_data <- case fp of
 384                   "-" -> getContents
 385                   _   -> readFile fp
 386   case parseData input_data of
 387     Bad err -> do
 388       hPutStrLn stderr $ "Error: " ++ err
 389       exitWith $ ExitFailure 1
 390     Ok (fix_msgs, rq) -> maybeShowWarnings fix_msgs >> return rq
 391
 392 -- | Main iallocator pipeline.
 393 runIAllocator :: Request -> (Maybe (Node.List, Instance.List), String)
 394 runIAllocator request =
 395   let (ok, info, result, cdata) =
 396         case processRequest request of
 397           Ok (msg, r, nl, il) -> (True, "Request successful: " ++ msg, r,
 398                                   Just (nl, il))
 399           Bad msg -> (False, "Request failed: " ++ msg, JSArray [], Nothing)
 400       rstring = formatResponse ok info result
 401   in (cdata, rstring)
 402
 403 -- | Load the data from an iallocation request file
 404 loadData :: FilePath -- ^ The path to the file
 405          -> IO (Result ClusterData)
 406 loadData fp = do
 407   Request _ cdata <- readRequest fp
 408   return $ Ok cdata