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)
  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 parseData :: String         -- ^ The JSON message as received from Ganeti
 129           -> Result Request -- ^ A (possible valid) request
 130 parseData body = do
 131   decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
 132   let obj = fromJSObject decoded
 133       extrObj x = tryFromObj "invalid iallocator message" obj x
 134   -- request parser
 135   request <- liftM fromJSObject (extrObj "request")
 136   let extrReq x = tryFromObj "invalid request dict" request x
 137   -- existing group parsing
 138   glist <- liftM fromJSObject (extrObj "nodegroups")
 139   gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist
 140   let (ktg, gl) = assignIndices gobj
 141   -- existing node parsing
 142   nlist <- liftM fromJSObject (extrObj "nodes")
 143   nobj <- mapM (\(x,y) ->
 144                     asJSObject y >>= parseNode ktg x . fromJSObject) nlist
 145   let (ktn, nl) = assignIndices nobj
 146   -- existing instance parsing
 147   ilist <- extrObj "instances"
 148   let idata = fromJSObject ilist
 149   iobj <- mapM (\(x,y) ->
 150                     asJSObject y >>= parseInstance ktn x . fromJSObject) idata
 151   let (kti, il) = assignIndices iobj
 152   -- cluster tags
 153   ctags <- extrObj "cluster_tags"
 154   cdata <- mergeData [] [] [] [] (ClusterData gl nl il ctags)
 155   let map_n = cdNodes cdata
 156       map_i = cdInstances cdata
 157       map_g = cdGroups cdata
 158   optype <- extrReq "type"
 159   rqtype <-
 160       case () of
 161         _ | optype == C.iallocatorModeAlloc ->
 162               do
 163                 rname     <- extrReq "name"
 164                 req_nodes <- extrReq "required_nodes"
 165                 inew      <- parseBaseInstance rname request
 166                 let io = snd inew
 167                 return $ Allocate io req_nodes
 168           | optype == C.iallocatorModeReloc ->
 169               do
 170                 rname     <- extrReq "name"
 171                 ridx      <- lookupInstance kti rname
 172                 req_nodes <- extrReq "required_nodes"
 173                 ex_nodes  <- extrReq "relocate_from"
 174                 ex_idex   <- mapM (Container.findByName map_n) ex_nodes
 175                 return $ Relocate ridx req_nodes (map Node.idx ex_idex)
 176           | optype == C.iallocatorModeMevac ->
 177               do
 178                 ex_names <- extrReq "evac_nodes"
 179                 ex_nodes <- mapM (Container.findByName map_n) ex_names
 180                 let ex_ndx = map Node.idx ex_nodes
 181                 return $ Evacuate ex_ndx
 182           | optype == C.iallocatorModeChgGroup ->
 183               do
 184                 rl_names <- extrReq "instances"
 185                 rl_insts <- mapM (liftM Instance.idx .
 186                                   Container.findByName map_i) rl_names
 187                 gr_uuids <- extrReq "target_groups"
 188                 gr_idxes <- mapM (liftM Group.idx .
 189                                   Container.findByName map_g) gr_uuids
 190                 return $ ChangeGroup rl_insts gr_idxes
 191           | optype == C.iallocatorModeNodeEvac ->
 192               do
 193                 rl_names <- extrReq "instances"
 194                 rl_insts <- mapM (Container.findByName map_i) rl_names
 195                 let rl_idx = map Instance.idx rl_insts
 196                 rl_mode <-
 197                    case extrReq "evac_mode" of
 198                      Ok s | s == C.iallocatorNevacAll -> return ChangeAll
 199                           | s == C.iallocatorNevacPri -> return ChangePrimary
 200                           | s == C.iallocatorNevacSec -> return ChangeSecondary
 201                           | otherwise -> Bad $ "Invalid evacuate mode " ++ s
 202                      Bad x -> Bad x
 203                 return $ NodeEvacuate rl_idx rl_mode
 204
 205           | otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
 206   return $ Request rqtype cdata
 207
 208 -- | Formats the result into a valid IAllocator response message.
 209 formatResponse :: Bool     -- ^ Whether the request was successful
 210                -> String   -- ^ Information text
 211                -> JSValue  -- ^ The JSON encoded result
 212                -> String   -- ^ The full JSON-formatted message
 213 formatResponse success info result =
 214     let
 215         e_success = ("success", showJSON success)
 216         e_info = ("info", showJSON info)
 217         e_result = ("result", result)
 218     in encodeStrict $ makeObj [e_success, e_info, e_result]
 219
 220 -- | Flatten the log of a solution into a string.
 221 describeSolution :: Cluster.AllocSolution -> String
 222 describeSolution = intercalate ", " . Cluster.asLog
 223
 224 -- | Convert evacuation results into the result format.
 225 formatEvacuate :: Cluster.AllocSolution -> Result IAllocResult
 226 formatEvacuate as = do
 227   let info = describeSolution as
 228       elems = Cluster.asSolutions as
 229   when (null elems) $ fail info
 230   let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl)
 231              elems
 232   return (info, showJSON sols)
 233
 234 -- | Convert allocation/relocation results into the result format.
 235 formatAllocate :: Cluster.AllocSolution -> Result IAllocResult
 236 formatAllocate as = do
 237   let info = describeSolution as
 238   case Cluster.asSolutions as of
 239     [] -> fail info
 240     (_, _, nodes, _):[] -> return (info, showJSON $ map (Node.name) nodes)
 241     _ -> fail "Internal error: multiple allocation solutions"
 242
 243 -- | Convert a node-evacuation/change group result.
 244 formatNodeEvac :: Cluster.EvacSolution -> Result IAllocResult
 245 formatNodeEvac es =
 246     let fes = Cluster.esFailed es
 247         mes = Cluster.esMoved es
 248         failed = length fes
 249         moved  = length mes
 250         info = show failed ++ " instances failed to move and " ++ show moved ++
 251                " were moved successfully"
 252     in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es))
 253
 254 -- | Process a request and return new node lists
 255 processRequest :: Request -> Result IAllocResult
 256 processRequest request =
 257   let Request rqtype (ClusterData gl nl il _) = request
 258   in case rqtype of
 259        Allocate xi reqn ->
 260            Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate
 261        Relocate idx reqn exnodes ->
 262            Cluster.tryMGReloc gl nl il idx reqn exnodes >>= formatAllocate
 263        Evacuate exnodes ->
 264            Cluster.tryMGEvac gl nl il exnodes >>= formatEvacuate
 265        ChangeGroup _ _ -> fail "Request 'change-group' not implemented"
 266        NodeEvacuate xi mode ->
 267            Cluster.tryNodeEvac gl nl il mode xi >>= formatNodeEvac
 268
 269 -- | Reads the request from the data file(s)
 270 readRequest :: Options -> [String] -> IO Request
 271 readRequest opts args = do
 272   when (null args) $ do
 273          hPutStrLn stderr "Error: this program needs an input file."
 274          exitWith $ ExitFailure 1
 275
 276   input_data <- readFile (head args)
 277   r1 <- case parseData input_data of
 278           Bad err -> do
 279             hPutStrLn stderr $ "Error: " ++ err
 280             exitWith $ ExitFailure 1
 281           Ok rq -> return rq
 282   (if isJust (optDataFile opts) ||  (not . null . optNodeSim) opts
 283    then do
 284      cdata <- loadExternalData opts
 285      let Request rqt _ = r1
 286      return $ Request rqt cdata
 287    else return r1)
 288
 289 -- | Main iallocator pipeline.
 290 runIAllocator :: Request -> String
 291 runIAllocator request =
 292   let (ok, info, result) =
 293           case processRequest request of
 294             Ok (msg, r) -> (True, "Request successful: " ++ msg, r)
 295             Bad msg -> (False, "Request failed: " ++ msg, JSArray [])
 296   in  formatResponse ok info result