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)
  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.JSON
  51 import Ganeti.HTools.Types
  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 extrReq x = tryFromObj "invalid request dict" request x
 149   -- existing group parsing
 150   glist <- liftM fromJSObject (extrObj "nodegroups")
 151   gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist
 152   let (ktg, gl) = assignIndices gobj
 153   -- existing node parsing
 154   nlist <- liftM fromJSObject (extrObj "nodes")
 155   nobj <- mapM (\(x,y) ->
 156                     asJSObject y >>= parseNode ktg x . fromJSObject) nlist
 157   let (ktn, nl) = assignIndices nobj
 158   -- existing instance parsing
 159   ilist <- extrObj "instances"
 160   let idata = fromJSObject ilist
 161   iobj <- mapM (\(x,y) ->
 162                     asJSObject y >>= parseInstance ktn x . fromJSObject) idata
 163   let (kti, il) = assignIndices iobj
 164   -- cluster tags
 165   ctags <- extrObj "cluster_tags"
 166   cdata1 <- mergeData [] [] [] [] (ClusterData gl nl il ctags defIPolicy)
 167   let (msgs, fix_nl) = checkData (cdNodes cdata1) (cdInstances cdata1)
 168       cdata = cdata1 { cdNodes = fix_nl }
 169       map_n = cdNodes cdata
 170       map_i = cdInstances cdata
 171       map_g = cdGroups cdata
 172   optype <- extrReq "type"
 173   rqtype <-
 174     case () of
 175       _ | optype == C.iallocatorModeAlloc ->
 176             do
 177               rname     <- extrReq "name"
 178               req_nodes <- extrReq "required_nodes"
 179               inew      <- parseBaseInstance rname request
 180               let io = snd inew
 181               return $ Allocate io req_nodes
 182         | optype == C.iallocatorModeReloc ->
 183             do
 184               rname     <- extrReq "name"
 185               ridx      <- lookupInstance kti rname
 186               req_nodes <- extrReq "required_nodes"
 187               ex_nodes  <- extrReq "relocate_from"
 188               ex_idex   <- mapM (Container.findByName map_n) ex_nodes
 189               return $ Relocate ridx req_nodes (map Node.idx ex_idex)
 190         | optype == C.iallocatorModeChgGroup ->
 191             do
 192               rl_names <- extrReq "instances"
 193               rl_insts <- mapM (liftM Instance.idx .
 194                                 Container.findByName map_i) rl_names
 195               gr_uuids <- extrReq "target_groups"
 196               gr_idxes <- mapM (liftM Group.idx .
 197                                 Container.findByName map_g) gr_uuids
 198               return $ ChangeGroup rl_insts gr_idxes
 199         | optype == C.iallocatorModeNodeEvac ->
 200             do
 201               rl_names <- extrReq "instances"
 202               rl_insts <- mapM (Container.findByName map_i) rl_names
 203               let rl_idx = map Instance.idx rl_insts
 204               rl_mode <- extrReq "evac_mode"
 205               return $ NodeEvacuate rl_idx rl_mode
 206
 207         | otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
 208   return (msgs, Request rqtype cdata)
 209
 210 -- | Formats the result into a valid IAllocator response message.
 211 formatResponse :: Bool     -- ^ Whether the request was successful
 212                -> String   -- ^ Information text
 213                -> JSValue  -- ^ The JSON encoded result
 214                -> String   -- ^ The full JSON-formatted message
 215 formatResponse success info result =
 216   let e_success = ("success", showJSON success)
 217       e_info = ("info", showJSON info)
 218       e_result = ("result", result)
 219   in encodeStrict $ makeObj [e_success, e_info, e_result]
 220
 221 -- | Flatten the log of a solution into a string.
 222 describeSolution :: Cluster.AllocSolution -> String
 223 describeSolution = intercalate ", " . Cluster.asLog
 224
 225 -- | Convert allocation/relocation results into the result format.
 226 formatAllocate :: Instance.List -> Cluster.AllocSolution -> Result IAllocResult
 227 formatAllocate il as = do
 228   let info = describeSolution as
 229   case Cluster.asSolution as of
 230     Nothing -> fail info
 231     Just (nl, inst, nodes, _) ->
 232       do
 233         let il' = Container.add (Instance.idx inst) inst il
 234         return (info, showJSON $ map Node.name nodes, nl, il')
 235
 236 -- | Convert a node-evacuation/change group result.
 237 formatNodeEvac :: Group.List
 238                -> Node.List
 239                -> Instance.List
 240                -> (Node.List, Instance.List, Cluster.EvacSolution)
 241                -> Result IAllocResult
 242 formatNodeEvac gl nl il (fin_nl, fin_il, es) =
 243   let iname = Instance.name . flip Container.find il
 244       nname = Node.name . flip Container.find nl
 245       gname = Group.name . flip Container.find gl
 246       fes = map (\(idx, msg) -> (iname idx, msg)) $ Cluster.esFailed es
 247       mes = map (\(idx, gdx, ndxs) -> (iname idx, gname gdx, map nname ndxs))
 248             $ Cluster.esMoved es
 249       failed = length fes
 250       moved  = length mes
 251       info = show failed ++ " instances failed to move and " ++ show moved ++
 252              " were moved successfully"
 253   in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es), fin_nl, fin_il)
 254
 255 -- | Runs relocate for a single instance.
 256 --
 257 -- This is wrapper over the 'Cluster.tryNodeEvac' function that is run
 258 -- with a single instance (ours), and further it checks that the
 259 -- result it got (in the nodes field) is actually consistent, as
 260 -- tryNodeEvac is designed to output primarily an opcode list, not a
 261 -- node list.
 262 processRelocate :: Group.List      -- ^ The group list
 263                 -> Node.List       -- ^ The node list
 264                 -> Instance.List   -- ^ The instance list
 265                 -> Idx             -- ^ The index of the instance to move
 266                 -> Int             -- ^ The number of nodes required
 267                 -> [Ndx]           -- ^ Nodes which should not be used
 268                 -> Result (Node.List, Instance.List, [Ndx]) -- ^ Solution list
 269 processRelocate gl nl il idx 1 exndx = do
 270   let orig = Container.find idx il
 271       sorig = Instance.sNode orig
 272       porig = Instance.pNode orig
 273       mir_type = Instance.mirrorType orig
 274   (exp_node, node_type, reloc_type) <-
 275     case mir_type of
 276       MirrorNone -> fail "Can't relocate non-mirrored instances"
 277       MirrorInternal -> return (sorig, "secondary", ChangeSecondary)
 278       MirrorExternal -> return (porig, "primary", ChangePrimary)
 279   when (exndx /= [exp_node]) $
 280        -- FIXME: we can't use the excluded nodes here; the logic is
 281        -- already _but only partially_ implemented in tryNodeEvac...
 282        fail $ "Unsupported request: excluded nodes not equal to\
 283               \ instance's " ++  node_type ++ "(" ++ show exp_node
 284               ++ " versus " ++ show exndx ++ ")"
 285   (nl', il', esol) <- Cluster.tryNodeEvac gl nl il reloc_type [idx]
 286   nodes <- case lookup idx (Cluster.esFailed esol) of
 287              Just msg -> fail msg
 288              Nothing ->
 289                  case lookup idx (map (\(a, _, b) -> (a, b))
 290                                   (Cluster.esMoved esol)) of
 291                    Nothing ->
 292                        fail "Internal error: lost instance idx during move"
 293                    Just n -> return n
 294   let inst = Container.find idx il'
 295       pnode = Instance.pNode inst
 296       snode = Instance.sNode inst
 297   nodes' <-
 298     case mir_type of
 299       MirrorNone -> fail "Internal error: mirror type none after relocation?!"
 300       MirrorInternal ->
 301         do
 302           when (snode == sorig) $
 303                fail "Internal error: instance didn't change secondary node?!"
 304           when (snode == pnode) $
 305                fail "Internal error: selected primary as new secondary?!"
 306           if nodes == [pnode, snode]
 307             then return [snode] -- only the new secondary is needed
 308             else fail $ "Internal error: inconsistent node list (" ++
 309                  show nodes ++ ") versus instance nodes (" ++ show pnode ++
 310                  "," ++ show snode ++ ")"
 311       MirrorExternal ->
 312         do
 313           when (pnode == porig) $
 314                fail "Internal error: instance didn't change primary node?!"
 315           if nodes == [pnode]
 316             then return nodes
 317             else fail $ "Internal error: inconsistent node list (" ++
 318                  show nodes ++ ") versus instance node (" ++ show pnode ++ ")"
 319   return (nl', il', nodes')
 320
 321 processRelocate _ _ _ _ reqn _ =
 322   fail $ "Exchange " ++ show reqn ++ " nodes mode is not implemented"
 323
 324 formatRelocate :: (Node.List, Instance.List, [Ndx])
 325                -> Result IAllocResult
 326 formatRelocate (nl, il, ndxs) =
 327   let nodes = map (`Container.find` nl) ndxs
 328       names = map Node.name nodes
 329   in Ok ("success", showJSON names, nl, il)
 330
 331 -- | Process a request and return new node lists.
 332 processRequest :: Request -> Result IAllocResult
 333 processRequest request =
 334   let Request rqtype (ClusterData gl nl il _ _) = request
 335   in case rqtype of
 336        Allocate xi reqn ->
 337          Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate il
 338        Relocate idx reqn exnodes ->
 339          processRelocate gl nl il idx reqn exnodes >>= formatRelocate
 340        ChangeGroup gdxs idxs ->
 341          Cluster.tryChangeGroup gl nl il idxs gdxs >>=
 342                 formatNodeEvac gl nl il
 343        NodeEvacuate xi mode ->
 344          Cluster.tryNodeEvac gl nl il mode xi >>=
 345                 formatNodeEvac gl nl il
 346
 347 -- | Reads the request from the data file(s).
 348 readRequest :: FilePath -> IO Request
 349 readRequest fp = do
 350   input_data <- case fp of
 351                   "-" -> getContents
 352                   _   -> readFile fp
 353   case parseData input_data of
 354     Bad err -> do
 355       hPutStrLn stderr $ "Error: " ++ err
 356       exitWith $ ExitFailure 1
 357     Ok (fix_msgs, rq) -> maybeShowWarnings fix_msgs >> return rq
 358
 359 -- | Main iallocator pipeline.
 360 runIAllocator :: Request -> (Maybe (Node.List, Instance.List), String)
 361 runIAllocator request =
 362   let (ok, info, result, cdata) =
 363         case processRequest request of
 364           Ok (msg, r, nl, il) -> (True, "Request successful: " ++ msg, r,
 365                                   Just (nl, il))
 366           Bad msg -> (False, "Request failed: " ++ msg, JSArray [], Nothing)
 367       rstring = formatResponse ok info result
 368   in (cdata, rstring)
 369
 370 -- | Load the data from an iallocation request file
 371 loadData :: FilePath -- ^ The path to the file
 372          -> IO (Result ClusterData)
 373 loadData fp = do
 374   Request _ cdata <- readRequest fp
 375   return $ Ok cdata