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 <- extrReq "evac_mode"
 188                 return $ NodeEvacuate rl_idx rl_mode
 189
 190           | otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
 191   return $ (msgs, Request rqtype cdata)
 192
 193 -- | Formats the result into a valid IAllocator response message.
 194 formatResponse :: Bool     -- ^ Whether the request was successful
 195                -> String   -- ^ Information text
 196                -> JSValue  -- ^ The JSON encoded result
 197                -> String   -- ^ The full JSON-formatted message
 198 formatResponse success info result =
 199     let
 200         e_success = ("success", showJSON success)
 201         e_info = ("info", showJSON info)
 202         e_result = ("result", result)
 203     in encodeStrict $ makeObj [e_success, e_info, e_result]
 204
 205 -- | Flatten the log of a solution into a string.
 206 describeSolution :: Cluster.AllocSolution -> String
 207 describeSolution = intercalate ", " . Cluster.asLog
 208
 209 -- | Convert allocation/relocation results into the result format.
 210 formatAllocate :: Instance.List -> Cluster.AllocSolution -> Result IAllocResult
 211 formatAllocate il as = do
 212   let info = describeSolution as
 213   case Cluster.asSolutions as of
 214     [] -> fail info
 215     (nl, inst, nodes, _):[] ->
 216         do
 217           let il' = Container.add (Instance.idx inst) inst il
 218           return (info, showJSON $ map (Node.name) nodes, nl, il')
 219     _ -> fail "Internal error: multiple allocation solutions"
 220
 221 -- | Convert a node-evacuation/change group result.
 222 formatNodeEvac :: Group.List
 223                -> Node.List
 224                -> Instance.List
 225                -> (Node.List, Instance.List, Cluster.EvacSolution)
 226                -> Result IAllocResult
 227 formatNodeEvac gl nl il (fin_nl, fin_il, es) =
 228     let iname = Instance.name . flip Container.find il
 229         nname = Node.name . flip Container.find nl
 230         gname = Group.name . flip Container.find gl
 231         fes = map (\(idx, msg) -> (iname idx, msg)) $ Cluster.esFailed es
 232         mes = map (\(idx, gdx, ndxs) -> (iname idx, gname gdx, map nname ndxs))
 233               $ Cluster.esMoved es
 234         failed = length fes
 235         moved  = length mes
 236         info = show failed ++ " instances failed to move and " ++ show moved ++
 237                " were moved successfully"
 238     in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es), fin_nl, fin_il)
 239
 240 -- | Process a request and return new node lists.
 241 processRequest :: Request -> Result IAllocResult
 242 processRequest request =
 243   let Request rqtype (ClusterData gl nl il _) = request
 244   in case rqtype of
 245        Allocate xi reqn ->
 246            Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate il
 247        ChangeGroup gdxs idxs ->
 248            Cluster.tryChangeGroup gl nl il idxs gdxs >>=
 249                   formatNodeEvac gl nl il
 250        NodeEvacuate xi mode ->
 251            Cluster.tryNodeEvac gl nl il mode xi >>=
 252                   formatNodeEvac gl nl il
 253
 254 -- | Reads the request from the data file(s).
 255 readRequest :: Options -> [String] -> IO Request
 256 readRequest opts args = do
 257   when (null args) $ do
 258          hPutStrLn stderr "Error: this program needs an input file."
 259          exitWith $ ExitFailure 1
 260
 261   input_data <- readFile (head args)
 262   r1 <- case parseData input_data of
 263           Bad err -> do
 264             hPutStrLn stderr $ "Error: " ++ err
 265             exitWith $ ExitFailure 1
 266           Ok (fix_msgs, rq) -> maybeShowWarnings fix_msgs >> return rq
 267   (if isJust (optDataFile opts) ||  (not . null . optNodeSim) opts
 268    then do
 269      cdata <- loadExternalData opts
 270      let Request rqt _ = r1
 271      return $ Request rqt cdata
 272    else return r1)
 273
 274 -- | Main iallocator pipeline.
 275 runIAllocator :: Request -> (Maybe (Node.List, Instance.List), String)
 276 runIAllocator request =
 277   let (ok, info, result, cdata) =
 278           case processRequest request of
 279             Ok (msg, r, nl, il) -> (True, "Request successful: " ++ msg, r,
 280                                     Just (nl, il))
 281             Bad msg -> (False, "Request failed: " ++ msg, JSArray [], Nothing)
 282       rstring = formatResponse ok info result
 283   in (cdata, rstring)