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   let running = "running"
  70   return (n, Instance.create n mem disk vcpus running tags True 0 0)
  71
  72 -- | Parses an instance as found in the cluster instance list.
  73 parseInstance :: NameAssoc -- ^ The node name-to-index association list
  74               -> String    -- ^ The name of the instance
  75               -> JSRecord  -- ^ The JSON object
  76               -> Result (String, Instance.Instance)
  77 parseInstance ktn n a = do
  78   base <- parseBaseInstance n a
  79   nodes <- fromObj a "nodes"
  80   pnode <- if null nodes
  81            then Bad $ "empty node list for instance " ++ n
  82            else readEitherString $ head nodes
  83   pidx <- lookupNode ktn n pnode
  84   let snodes = tail nodes
  85   sidx <- (if null snodes then return Node.noSecondary
  86            else readEitherString (head snodes) >>= lookupNode ktn n)
  87   return (n, Instance.setBoth (snd base) pidx sidx)
  88
  89 -- | Parses a node as found in the cluster node list.
  90 parseNode :: NameAssoc   -- ^ The group association
  91           -> String      -- ^ The node's name
  92           -> JSRecord    -- ^ The JSON object
  93           -> Result (String, Node.Node)
  94 parseNode ktg n a = do
  95   let desc = "invalid data for node '" ++ n ++ "'"
  96       extract x = tryFromObj desc a x
  97   offline <- extract "offline"
  98   drained <- extract "drained"
  99   guuid   <- extract "group"
 100   vm_capable  <- annotateResult desc $ maybeFromObj a "vm_capable"
 101   let vm_capable' = fromMaybe True vm_capable
 102   gidx <- lookupGroup ktg n guuid
 103   node <- (if offline || drained || not vm_capable'
 104            then return $ Node.create n 0 0 0 0 0 0 True gidx
 105            else do
 106              mtotal <- extract "total_memory"
 107              mnode  <- extract "reserved_memory"
 108              mfree  <- extract "free_memory"
 109              dtotal <- extract "total_disk"
 110              dfree  <- extract "free_disk"
 111              ctotal <- extract "total_cpus"
 112              return $ Node.create n mtotal mnode mfree
 113                     dtotal dfree ctotal False gidx)
 114   return (n, node)
 115
 116 -- | Parses a group as found in the cluster group list.
 117 parseGroup :: String     -- ^ The group UUID
 118            -> JSRecord   -- ^ The JSON object
 119            -> Result (String, Group.Group)
 120 parseGroup u a = do
 121   let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x
 122   name <- extract "name"
 123   apol <- extract "alloc_policy"
 124   return (u, Group.create name u apol)
 125
 126 parseTargetGroups :: JSRecord      -- ^ The JSON object (request dict)
 127                   -> Group.List    -- ^ The existing groups
 128                   -> Result [Gdx]
 129 parseTargetGroups req map_g = do
 130   group_uuids <- fromObjWithDefault req "target_groups" []
 131   mapM (liftM Group.idx . Container.findByName map_g) group_uuids
 132
 133 -- | Top-level parser.
 134 parseData :: String         -- ^ The JSON message as received from Ganeti
 135           -> Result Request -- ^ A (possible valid) request
 136 parseData body = do
 137   decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
 138   let obj = fromJSObject decoded
 139       extrObj x = tryFromObj "invalid iallocator message" obj x
 140   -- request parser
 141   request <- liftM fromJSObject (extrObj "request")
 142   let extrReq x = tryFromObj "invalid request dict" request x
 143   -- existing group parsing
 144   glist <- liftM fromJSObject (extrObj "nodegroups")
 145   gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist
 146   let (ktg, gl) = assignIndices gobj
 147   -- existing node parsing
 148   nlist <- liftM fromJSObject (extrObj "nodes")
 149   nobj <- mapM (\(x,y) ->
 150                     asJSObject y >>= parseNode ktg x . fromJSObject) nlist
 151   let (ktn, nl) = assignIndices nobj
 152   -- existing instance parsing
 153   ilist <- extrObj "instances"
 154   let idata = fromJSObject ilist
 155   iobj <- mapM (\(x,y) ->
 156                     asJSObject y >>= parseInstance ktn x . fromJSObject) idata
 157   let (kti, il) = assignIndices iobj
 158   -- cluster tags
 159   ctags <- extrObj "cluster_tags"
 160   cdata <- mergeData [] [] [] [] (ClusterData gl nl il ctags)
 161   let map_n = cdNodes cdata
 162       map_i = cdInstances cdata
 163       map_g = cdGroups cdata
 164   optype <- extrReq "type"
 165   rqtype <-
 166       case () of
 167         _ | optype == C.iallocatorModeAlloc ->
 168               do
 169                 rname     <- extrReq "name"
 170                 req_nodes <- extrReq "required_nodes"
 171                 inew      <- parseBaseInstance rname request
 172                 let io = snd inew
 173                 return $ Allocate io req_nodes
 174           | optype == C.iallocatorModeReloc ->
 175               do
 176                 rname     <- extrReq "name"
 177                 ridx      <- lookupInstance kti rname
 178                 req_nodes <- extrReq "required_nodes"
 179                 ex_nodes  <- extrReq "relocate_from"
 180                 ex_idex   <- mapM (Container.findByName map_n) ex_nodes
 181                 return $ Relocate ridx req_nodes (map Node.idx ex_idex)
 182           | optype == C.iallocatorModeMevac ->
 183               do
 184                 ex_names <- extrReq "evac_nodes"
 185                 ex_nodes <- mapM (Container.findByName map_n) ex_names
 186                 let ex_ndx = map Node.idx ex_nodes
 187                 return $ Evacuate ex_ndx
 188           | optype == C.iallocatorModeMreloc ->
 189               do
 190                 rl_names <- extrReq "instances"
 191                 rl_insts <- mapM (Container.findByName map_i) rl_names
 192                 let rl_idx = map Instance.idx rl_insts
 193                 rl_mode <-
 194                    case extrReq "reloc_mode" of
 195                      Ok s | s == C.iallocatorMrelocKeep -> return KeepGroup
 196                           | s == C.iallocatorMrelocChange ->
 197                               do
 198                                 tg_groups <- parseTargetGroups request map_g
 199                                 return $ ChangeGroup tg_groups
 200                           | s == C.iallocatorMrelocAny -> return AnyGroup
 201                           | otherwise -> Bad $ "Invalid relocate mode " ++ s
 202                      Bad x -> Bad x
 203                 return $ MultiReloc rl_idx rl_mode
 204           | optype == C.iallocatorModeNodeEvac ->
 205               do
 206                 rl_names <- extrReq "instances"
 207                 rl_insts <- mapM (Container.findByName map_i) rl_names
 208                 let rl_idx = map Instance.idx rl_insts
 209                 rl_mode <-
 210                    case extrReq "evac_mode" of
 211                      Ok s | s == C.iallocatorNevacAll -> return ChangeAll
 212                           | s == C.iallocatorNevacPri -> return ChangePrimary
 213                           | s == C.iallocatorNevacSec -> return ChangeSecondary
 214                           | otherwise -> Bad $ "Invalid evacuate mode " ++ s
 215                      Bad x -> Bad x
 216                 return $ NodeEvacuate rl_idx rl_mode
 217
 218           | otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
 219   return $ Request rqtype cdata
 220
 221 -- | Formats the result into a valid IAllocator response message.
 222 formatResponse :: Bool     -- ^ Whether the request was successful
 223                -> String   -- ^ Information text
 224                -> JSValue  -- ^ The JSON encoded result
 225                -> String   -- ^ The full JSON-formatted message
 226 formatResponse success info result =
 227     let
 228         e_success = ("success", showJSON success)
 229         e_info = ("info", showJSON info)
 230         e_result = ("result", result)
 231     in encodeStrict $ makeObj [e_success, e_info, e_result]
 232
 233 -- | Flatten the log of a solution into a string.
 234 describeSolution :: Cluster.AllocSolution -> String
 235 describeSolution = intercalate ", " . Cluster.asLog
 236
 237 -- | Convert evacuation results into the result format.
 238 formatEvacuate :: Cluster.AllocSolution -> Result IAllocResult
 239 formatEvacuate as = do
 240   let info = describeSolution as
 241       elems = Cluster.asSolutions as
 242   when (null elems) $ fail info
 243   let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl)
 244              elems
 245   return (info, showJSON sols)
 246
 247 -- | Convert allocation/relocation results into the result format.
 248 formatAllocate :: Cluster.AllocSolution -> Result IAllocResult
 249 formatAllocate as = do
 250   let info = describeSolution as
 251   case Cluster.asSolutions as of
 252     [] -> fail info
 253     (_, _, nodes, _):[] -> return (info, showJSON $ map (Node.name) nodes)
 254     _ -> fail "Internal error: multiple allocation solutions"
 255
 256 -- | Process a request and return new node lists
 257 processRequest :: Request -> Result IAllocResult
 258 processRequest request =
 259   let Request rqtype (ClusterData gl nl il _) = request
 260   in case rqtype of
 261        Allocate xi reqn ->
 262            Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate
 263        Relocate idx reqn exnodes ->
 264            Cluster.tryMGReloc gl nl il idx reqn exnodes >>= formatAllocate
 265        Evacuate exnodes ->
 266            Cluster.tryMGEvac gl nl il exnodes >>= formatEvacuate
 267        MultiReloc _ _ -> fail "multi-reloc not handled"
 268        NodeEvacuate _ _ -> fail "node-evacuate not handled"
 269
 270 -- | Reads the request from the data file(s)
 271 readRequest :: Options -> [String] -> IO Request
 272 readRequest opts args = do
 273   when (null args) $ do
 274          hPutStrLn stderr "Error: this program needs an input file."
 275          exitWith $ ExitFailure 1
 276
 277   input_data <- readFile (head args)
 278   r1 <- case parseData input_data of
 279           Bad err -> do
 280             hPutStrLn stderr $ "Error: " ++ err
 281             exitWith $ ExitFailure 1
 282           Ok rq -> return rq
 283   (if isJust (optDataFile opts) ||  (not . null . optNodeSim) opts
 284    then do
 285      cdata <- loadExternalData opts
 286      let Request rqt _ = r1
 287      return $ Request rqt cdata
 288    else return r1)
 289
 290 -- | Main iallocator pipeline.
 291 runIAllocator :: Request -> String
 292 runIAllocator request =
 293   let (ok, info, result) =
 294           case processRequest request of
 295             Ok (msg, r) -> (True, "Request successful: " ++ msg, r)
 296             Bad msg -> (False, "Request failed: " ++ msg, JSArray [])
 297   in  formatResponse ok info result