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