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