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