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