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