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

   1 {-| Implementation of the iallocator interface.
   2
   3 -}
   4
   5 {-
   6
   7 Copyright (C) 2009, 2010, 2011, 2012, 2013 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.Backend.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 System.Time
  38 import Text.JSON (JSObject, JSValue(JSArray),
  39                   makeObj, encodeStrict, decodeStrict, fromJSObject, showJSON)
  40
  41 import Ganeti.BasicTypes
  42 import qualified Ganeti.HTools.Cluster as Cluster
  43 import qualified Ganeti.HTools.Container as Container
  44 import qualified Ganeti.HTools.Group as Group
  45 import qualified Ganeti.HTools.Node as Node
  46 import qualified Ganeti.HTools.Instance as Instance
  47 import qualified Ganeti.Constants as C
  48 import Ganeti.HTools.CLI
  49 import Ganeti.HTools.Loader
  50 import Ganeti.HTools.Types
  51 import Ganeti.JSON
  52 import Ganeti.Utils
  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, snodes) <-
  86     case nodes of
  87       [] -> Bad $ "empty node list for instance " ++ n
  88       x:xs -> readEitherString x >>= \x' -> return (x', xs)
  89   pidx <- lookupNode ktn n pnode
  90   sidx <- case snodes of
  91             [] -> return Node.noSecondary
  92             x:_ -> readEitherString x >>= 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   tags <- extract "tags"
 135   return (u, Group.create name u apol ipol tags)
 136
 137 -- | Top-level parser.
 138 --
 139 -- The result is a tuple of eventual warning messages and the parsed
 140 -- request; if parsing the input data fails, we'll return a 'Bad'
 141 -- value.
 142 parseData :: ClockTime -- ^ The current time
 143           -> String -- ^ The JSON message as received from Ganeti
 144           -> Result ([String], Request) -- ^ Result tuple
 145 parseData now body = do
 146   decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
 147   let obj = fromJSObject decoded
 148       extrObj x = tryFromObj "invalid iallocator message" obj x
 149   -- request parser
 150   request <- liftM fromJSObject (extrObj "request")
 151   let extrFromReq r x = tryFromObj "invalid request dict" r x
 152   let extrReq x = extrFromReq request x
 153   -- existing group parsing
 154   glist <- liftM fromJSObject (extrObj "nodegroups")
 155   gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist
 156   let (ktg, gl) = assignIndices gobj
 157   -- existing node parsing
 158   nlist <- liftM fromJSObject (extrObj "nodes")
 159   nobj <- mapM (\(x,y) ->
 160                     asJSObject y >>= parseNode ktg x . fromJSObject) nlist
 161   let (ktn, nl) = assignIndices nobj
 162   -- existing instance parsing
 163   ilist <- extrObj "instances"
 164   let idata = fromJSObject ilist
 165   iobj <- mapM (\(x,y) ->
 166                     asJSObject y >>= parseInstance ktn x . fromJSObject) idata
 167   let (kti, il) = assignIndices iobj
 168   -- cluster tags
 169   ctags <- extrObj "cluster_tags"
 170   cdata1 <- mergeData [] [] [] [] now (ClusterData gl nl il ctags defIPolicy)
 171   let (msgs, fix_nl) = checkData (cdNodes cdata1) (cdInstances cdata1)
 172       cdata = cdata1 { cdNodes = fix_nl }
 173       map_n = cdNodes cdata
 174       map_i = cdInstances cdata
 175       map_g = cdGroups cdata
 176   optype <- extrReq "type"
 177   rqtype <-
 178     case () of
 179       _ | optype == C.iallocatorModeAlloc ->
 180             do
 181               rname     <- extrReq "name"
 182               req_nodes <- extrReq "required_nodes"
 183               inew      <- parseBaseInstance rname request
 184               let io = snd inew
 185               return $ Allocate io req_nodes
 186         | optype == C.iallocatorModeReloc ->
 187             do
 188               rname     <- extrReq "name"
 189               ridx      <- lookupInstance kti rname
 190               req_nodes <- extrReq "required_nodes"
 191               ex_nodes  <- extrReq "relocate_from"
 192               ex_idex   <- mapM (Container.findByName map_n) ex_nodes
 193               return $ Relocate ridx req_nodes (map Node.idx ex_idex)
 194         | optype == C.iallocatorModeChgGroup ->
 195             do
 196               rl_names <- extrReq "instances"
 197               rl_insts <- mapM (liftM Instance.idx .
 198                                 Container.findByName map_i) rl_names
 199               gr_uuids <- extrReq "target_groups"
 200               gr_idxes <- mapM (liftM Group.idx .
 201                                 Container.findByName map_g) gr_uuids
 202               return $ ChangeGroup rl_insts gr_idxes
 203         | optype == C.iallocatorModeNodeEvac ->
 204             do
 205               rl_names <- extrReq "instances"
 206               rl_insts <- mapM (Container.findByName map_i) rl_names
 207               let rl_idx = map Instance.idx rl_insts
 208               rl_mode <- extrReq "evac_mode"
 209               return $ NodeEvacuate rl_idx rl_mode
 210         | optype == C.iallocatorModeMultiAlloc ->
 211             do
 212               arry <- extrReq "instances" :: Result [JSObject JSValue]
 213               let inst_reqs = map fromJSObject arry
 214               prqs <- mapM (\r ->
 215                                do
 216                                  rname     <- extrFromReq r "name"
 217                                  req_nodes <- extrFromReq r "required_nodes"
 218                                  inew      <- parseBaseInstance rname r
 219                                  let io = snd inew
 220                                  return (io, req_nodes)) inst_reqs
 221               return $ MultiAllocate prqs
 222         | otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
 223   return (msgs, Request rqtype cdata)
 224
 225 -- | Formats the result into a valid IAllocator response message.
 226 formatResponse :: Bool     -- ^ Whether the request was successful
 227                -> String   -- ^ Information text
 228                -> JSValue  -- ^ The JSON encoded result
 229                -> String   -- ^ The full JSON-formatted message
 230 formatResponse success info result =
 231   let e_success = ("success", showJSON success)
 232       e_info = ("info", showJSON info)
 233       e_result = ("result", result)
 234   in encodeStrict $ makeObj [e_success, e_info, e_result]
 235
 236 -- | Flatten the log of a solution into a string.
 237 describeSolution :: Cluster.AllocSolution -> String
 238 describeSolution = intercalate ", " . Cluster.asLog
 239
 240 -- | Convert allocation/relocation results into the result format.
 241 formatAllocate :: Instance.List -> Cluster.AllocSolution -> Result IAllocResult
 242 formatAllocate il as = do
 243   let info = describeSolution as
 244   case Cluster.asSolution as of
 245     Nothing -> fail info
 246     Just (nl, inst, nodes, _) ->
 247       do
 248         let il' = Container.add (Instance.idx inst) inst il
 249         return (info, showJSON $ map Node.name nodes, nl, il')
 250
 251 -- | Convert multi allocation results into the result format.
 252 formatMultiAlloc :: (Node.List, Instance.List, Cluster.AllocSolutionList)
 253                  -> Result IAllocResult
 254 formatMultiAlloc (fin_nl, fin_il, ars) =
 255   let rars = reverse ars
 256       (allocated, failed) = partition (isJust . Cluster.asSolution . snd) rars
 257       aars = map (\(_, ar) ->
 258                      let (_, inst, nodes, _) = fromJust $ Cluster.asSolution ar
 259                          iname = Instance.name inst
 260                          nnames = map Node.name nodes
 261                      in (iname, nnames)) allocated
 262       fars = map (\(inst, ar) ->
 263                      let iname = Instance.name inst
 264                      in (iname, describeSolution ar)) failed
 265       info = show (length failed) ++ " instances failed to allocate and " ++
 266              show (length allocated) ++ " were allocated successfully"
 267   in return (info, showJSON (aars, fars), fin_nl, fin_il)
 268
 269 -- | Convert a node-evacuation/change group result.
 270 formatNodeEvac :: Group.List
 271                -> Node.List
 272                -> Instance.List
 273                -> (Node.List, Instance.List, Cluster.EvacSolution)
 274                -> Result IAllocResult
 275 formatNodeEvac gl nl il (fin_nl, fin_il, es) =
 276   let iname = Instance.name . flip Container.find il
 277       nname = Node.name . flip Container.find nl
 278       gname = Group.name . flip Container.find gl
 279       fes = map (\(idx, msg) -> (iname idx, msg)) $ Cluster.esFailed es
 280       mes = map (\(idx, gdx, ndxs) -> (iname idx, gname gdx, map nname ndxs))
 281             $ Cluster.esMoved es
 282       failed = length fes
 283       moved  = length mes
 284       info = show failed ++ " instances failed to move and " ++ show moved ++
 285              " were moved successfully"
 286   in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es), fin_nl, fin_il)
 287
 288 -- | Runs relocate for a single instance.
 289 --
 290 -- This is wrapper over the 'Cluster.tryNodeEvac' function that is run
 291 -- with a single instance (ours), and further it checks that the
 292 -- result it got (in the nodes field) is actually consistent, as
 293 -- tryNodeEvac is designed to output primarily an opcode list, not a
 294 -- node list.
 295 processRelocate :: Group.List      -- ^ The group list
 296                 -> Node.List       -- ^ The node list
 297                 -> Instance.List   -- ^ The instance list
 298                 -> Idx             -- ^ The index of the instance to move
 299                 -> Int             -- ^ The number of nodes required
 300                 -> [Ndx]           -- ^ Nodes which should not be used
 301                 -> Result (Node.List, Instance.List, [Ndx]) -- ^ Solution list
 302 processRelocate gl nl il idx 1 exndx = do
 303   let orig = Container.find idx il
 304       sorig = Instance.sNode orig
 305       porig = Instance.pNode orig
 306       mir_type = Instance.mirrorType orig
 307   (exp_node, node_type, reloc_type) <-
 308     case mir_type of
 309       MirrorNone -> fail "Can't relocate non-mirrored instances"
 310       MirrorInternal -> return (sorig, "secondary", ChangeSecondary)
 311       MirrorExternal -> return (porig, "primary", ChangePrimary)
 312   when (exndx /= [exp_node]) .
 313        -- FIXME: we can't use the excluded nodes here; the logic is
 314        -- already _but only partially_ implemented in tryNodeEvac...
 315        fail $ "Unsupported request: excluded nodes not equal to\
 316               \ instance's " ++  node_type ++ "(" ++ show exp_node
 317               ++ " versus " ++ show exndx ++ ")"
 318   (nl', il', esol) <- Cluster.tryNodeEvac gl nl il reloc_type [idx]
 319   nodes <- case lookup idx (Cluster.esFailed esol) of
 320              Just msg -> fail msg
 321              Nothing ->
 322                  case lookup idx (map (\(a, _, b) -> (a, b))
 323                                   (Cluster.esMoved esol)) of
 324                    Nothing ->
 325                        fail "Internal error: lost instance idx during move"
 326                    Just n -> return n
 327   let inst = Container.find idx il'
 328       pnode = Instance.pNode inst
 329       snode = Instance.sNode inst
 330   nodes' <-
 331     case mir_type of
 332       MirrorNone -> fail "Internal error: mirror type none after relocation?!"
 333       MirrorInternal ->
 334         do
 335           when (snode == sorig) $
 336                fail "Internal error: instance didn't change secondary node?!"
 337           when (snode == pnode) $
 338                fail "Internal error: selected primary as new secondary?!"
 339           if nodes == [pnode, snode]
 340             then return [snode] -- only the new secondary is needed
 341             else fail $ "Internal error: inconsistent node list (" ++
 342                  show nodes ++ ") versus instance nodes (" ++ show pnode ++
 343                  "," ++ show snode ++ ")"
 344       MirrorExternal ->
 345         do
 346           when (pnode == porig) $
 347                fail "Internal error: instance didn't change primary node?!"
 348           if nodes == [pnode]
 349             then return nodes
 350             else fail $ "Internal error: inconsistent node list (" ++
 351                  show nodes ++ ") versus instance node (" ++ show pnode ++ ")"
 352   return (nl', il', nodes')
 353
 354 processRelocate _ _ _ _ reqn _ =
 355   fail $ "Exchange " ++ show reqn ++ " nodes mode is not implemented"
 356
 357 formatRelocate :: (Node.List, Instance.List, [Ndx])
 358                -> Result IAllocResult
 359 formatRelocate (nl, il, ndxs) =
 360   let nodes = map (`Container.find` nl) ndxs
 361       names = map Node.name nodes
 362   in Ok ("success", showJSON names, nl, il)
 363
 364 -- | Process a request and return new node lists.
 365 processRequest :: Request -> Result IAllocResult
 366 processRequest request =
 367   let Request rqtype (ClusterData gl nl il _ _) = request
 368   in case rqtype of
 369        Allocate xi reqn ->
 370          Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate il
 371        Relocate idx reqn exnodes ->
 372          processRelocate gl nl il idx reqn exnodes >>= formatRelocate
 373        ChangeGroup gdxs idxs ->
 374          Cluster.tryChangeGroup gl nl il idxs gdxs >>=
 375                 formatNodeEvac gl nl il
 376        NodeEvacuate xi mode ->
 377          Cluster.tryNodeEvac gl nl il mode xi >>=
 378                 formatNodeEvac gl nl il
 379        MultiAllocate xies ->
 380          Cluster.allocList gl nl il xies [] >>= formatMultiAlloc
 381
 382 -- | Reads the request from the data file(s).
 383 readRequest :: FilePath -> IO Request
 384 readRequest fp = do
 385   now <- getClockTime
 386   input_data <- case fp of
 387                   "-" -> getContents
 388                   _   -> readFile fp
 389   case parseData now input_data of
 390     Bad err -> exitErr err
 391     Ok (fix_msgs, rq) -> maybeShowWarnings fix_msgs >> return rq
 392
 393 -- | Main iallocator pipeline.
 394 runIAllocator :: Request -> (Maybe (Node.List, Instance.List), String)
 395 runIAllocator request =
 396   let (ok, info, result, cdata) =
 397         case processRequest request of
 398           Ok (msg, r, nl, il) -> (True, "Request successful: " ++ msg, r,
 399                                   Just (nl, il))
 400           Bad msg -> (False, "Request failed: " ++ msg, JSArray [], Nothing)
 401       rstring = formatResponse ok info result
 402   in (cdata, rstring)
 403
 404 -- | Load the data from an iallocation request file
 405 loadData :: FilePath -- ^ The path to the file
 406          -> IO (Result ClusterData)
 407 loadData fp = do
 408   Request _ cdata <- readRequest fp
 409   return $ Ok cdata