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