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(JSBool, JSString, JSArray),
  36                   makeObj, encodeStrict, decodeStrict,
  37                   fromJSObject, toJSString)
  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)
  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   let running = "running"
  71   return (n, Instance.create n mem disk vcpus running tags True 0 0)
  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", JSBool success)
 230         e_info = ("info", JSString . toJSString $ 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       jsols = map (JSArray . map (JSString . toJSString)) sols
 247   return (info, JSArray jsols)
 248
 249 -- | Convert allocation/relocation results into the result format.
 250 formatAllocate :: Cluster.AllocSolution -> Result IAllocResult
 251 formatAllocate as = do
 252   let info = describeSolution as
 253   case Cluster.asSolutions as of
 254     [] -> fail info
 255     (_, _, nodes, _):[] -> do
 256         let nodes' = map Node.name nodes
 257         return (info, JSArray $ map (JSString . toJSString) nodes')
 258     _ -> fail "Internal error: multiple allocation solutions"
 259
 260 -- | Process a request and return new node lists
 261 processRequest :: Request -> Result IAllocResult
 262 processRequest request =
 263   let Request rqtype (ClusterData gl nl il _) = request
 264   in case rqtype of
 265        Allocate xi reqn ->
 266            Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate
 267        Relocate idx reqn exnodes ->
 268            Cluster.tryMGReloc gl nl il idx reqn exnodes >>= formatAllocate
 269        Evacuate exnodes ->
 270            Cluster.tryMGEvac gl nl il exnodes >>= formatEvacuate
 271        MultiReloc _ _ -> fail "multi-reloc not handled"
 272        NodeEvacuate _ _ -> fail "node-evacuate not handled"
 273
 274 -- | Reads the request from the data file(s)
 275 readRequest :: Options -> [String] -> IO Request
 276 readRequest opts args = do
 277   when (null args) $ do
 278          hPutStrLn stderr "Error: this program needs an input file."
 279          exitWith $ ExitFailure 1
 280
 281   input_data <- readFile (head args)
 282   r1 <- case parseData input_data of
 283           Bad err -> do
 284             hPutStrLn stderr $ "Error: " ++ err
 285             exitWith $ ExitFailure 1
 286           Ok rq -> return rq
 287   (if isJust (optDataFile opts) ||  (not . null . optNodeSim) opts
 288    then do
 289      cdata <- loadExternalData opts
 290      let Request rqt _ = r1
 291      return $ Request rqt cdata
 292    else return r1)
 293
 294 -- | Main iallocator pipeline.
 295 runIAllocator :: Request -> String
 296 runIAllocator request =
 297   let (ok, info, result) =
 298           case processRequest request of
 299             Ok (msg, r) -> (True, "Request successful: " ++ msg, r)
 300             Bad msg -> (False, "Request failed: " ++ msg, JSArray [])
 301   in  formatResponse ok info result