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