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     ( parseData
  28     , formatResponse
  29     ) where
  30
  31 import Data.Either ()
  32 import Data.Maybe (fromMaybe)
  33 import Control.Monad
  34 import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
  35                   makeObj, encodeStrict, decodeStrict,
  36                   fromJSObject, toJSString)
  37 import qualified Ganeti.HTools.Container as Container
  38 import qualified Ganeti.HTools.Group as Group
  39 import qualified Ganeti.HTools.Node as Node
  40 import qualified Ganeti.HTools.Instance as Instance
  41 import qualified Ganeti.Constants as C
  42 import Ganeti.HTools.Loader
  43 import Ganeti.HTools.Utils
  44 import Ganeti.HTools.Types
  45
  46 -- | Parse the basic specifications of an instance.
  47 --
  48 -- Instances in the cluster instance list and the instance in an
  49 -- 'Allocate' request share some common properties, which are read by
  50 -- this function.
  51 parseBaseInstance :: String
  52                   -> JSRecord
  53                   -> Result (String, Instance.Instance)
  54 parseBaseInstance n a = do
  55   let extract x = tryFromObj ("invalid data for instance '" ++ n ++ "'") a x
  56   disk  <- extract "disk_space_total"
  57   mem   <- extract "memory"
  58   vcpus <- extract "vcpus"
  59   tags  <- extract "tags"
  60   let running = "running"
  61   return (n, Instance.create n mem disk vcpus running tags True 0 0)
  62
  63 -- | Parses an instance as found in the cluster instance list.
  64 parseInstance :: NameAssoc -- ^ The node name-to-index association list
  65               -> String    -- ^ The name of the instance
  66               -> JSRecord  -- ^ The JSON object
  67               -> Result (String, Instance.Instance)
  68 parseInstance ktn n a = do
  69   base <- parseBaseInstance n a
  70   nodes <- fromObj a "nodes"
  71   pnode <- if null nodes
  72            then Bad $ "empty node list for instance " ++ n
  73            else readEitherString $ head nodes
  74   pidx <- lookupNode ktn n pnode
  75   let snodes = tail nodes
  76   sidx <- (if null snodes then return Node.noSecondary
  77            else readEitherString (head snodes) >>= lookupNode ktn n)
  78   return (n, Instance.setBoth (snd base) pidx sidx)
  79
  80 -- | Parses a node as found in the cluster node list.
  81 parseNode :: NameAssoc   -- ^ The group association
  82           -> String      -- ^ The node's name
  83           -> JSRecord    -- ^ The JSON object
  84           -> Result (String, Node.Node)
  85 parseNode ktg n a = do
  86   let desc = "invalid data for node '" ++ n ++ "'"
  87       extract x = tryFromObj desc a x
  88   offline <- extract "offline"
  89   drained <- extract "drained"
  90   guuid   <- extract "group"
  91   vm_capable  <- annotateResult desc $ maybeFromObj a "vm_capable"
  92   let vm_capable' = fromMaybe True vm_capable
  93   gidx <- lookupGroup ktg n guuid
  94   node <- (if offline || drained || not vm_capable'
  95            then return $ Node.create n 0 0 0 0 0 0 True gidx
  96            else do
  97              mtotal <- extract "total_memory"
  98              mnode  <- extract "reserved_memory"
  99              mfree  <- extract "free_memory"
 100              dtotal <- extract "total_disk"
 101              dfree  <- extract "free_disk"
 102              ctotal <- extract "total_cpus"
 103              return $ Node.create n mtotal mnode mfree
 104                     dtotal dfree ctotal False gidx)
 105   return (n, node)
 106
 107 -- | Parses a group as found in the cluster group list.
 108 parseGroup :: String     -- ^ The group UUID
 109            -> JSRecord   -- ^ The JSON object
 110            -> Result (String, Group.Group)
 111 parseGroup u a = do
 112   let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x
 113   name <- extract "name"
 114   apol <- extract "alloc_policy"
 115   return (u, Group.create name u apol)
 116
 117 parseTargetGroups :: JSRecord      -- ^ The JSON object (request dict)
 118                   -> Group.List    -- ^ The existing groups
 119                   -> Result [Gdx]
 120 parseTargetGroups req map_g = do
 121   group_uuids <- fromObjWithDefault req "target_groups" []
 122   mapM (liftM Group.idx . Container.findByName map_g) group_uuids
 123
 124 -- | Top-level parser.
 125 parseData :: String         -- ^ The JSON message as received from Ganeti
 126           -> Result Request -- ^ A (possible valid) request
 127 parseData body = do
 128   decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
 129   let obj = fromJSObject decoded
 130       extrObj x = tryFromObj "invalid iallocator message" obj x
 131   -- request parser
 132   request <- liftM fromJSObject (extrObj "request")
 133   let extrReq x = tryFromObj "invalid request dict" request x
 134   -- existing group parsing
 135   glist <- liftM fromJSObject (extrObj "nodegroups")
 136   gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist
 137   let (ktg, gl) = assignIndices gobj
 138   -- existing node parsing
 139   nlist <- liftM fromJSObject (extrObj "nodes")
 140   nobj <- mapM (\(x,y) ->
 141                     asJSObject y >>= parseNode ktg x . fromJSObject) nlist
 142   let (ktn, nl) = assignIndices nobj
 143   -- existing instance parsing
 144   ilist <- extrObj "instances"
 145   let idata = fromJSObject ilist
 146   iobj <- mapM (\(x,y) ->
 147                     asJSObject y >>= parseInstance ktn x . fromJSObject) idata
 148   let (kti, il) = assignIndices iobj
 149   -- cluster tags
 150   ctags <- extrObj "cluster_tags"
 151   cdata <- mergeData [] [] [] [] (ClusterData gl nl il ctags)
 152   let map_n = cdNodes cdata
 153       map_i = cdInstances cdata
 154       map_g = cdGroups cdata
 155   optype <- extrReq "type"
 156   rqtype <-
 157       case () of
 158         _ | optype == C.iallocatorModeAlloc ->
 159               do
 160                 rname     <- extrReq "name"
 161                 req_nodes <- extrReq "required_nodes"
 162                 inew      <- parseBaseInstance rname request
 163                 let io = snd inew
 164                 return $ Allocate io req_nodes
 165           | optype == C.iallocatorModeReloc ->
 166               do
 167                 rname     <- extrReq "name"
 168                 ridx      <- lookupInstance kti rname
 169                 req_nodes <- extrReq "required_nodes"
 170                 ex_nodes  <- extrReq "relocate_from"
 171                 ex_idex   <- mapM (Container.findByName map_n) ex_nodes
 172                 return $ Relocate ridx req_nodes (map Node.idx ex_idex)
 173           | optype == C.iallocatorModeMevac ->
 174               do
 175                 ex_names <- extrReq "evac_nodes"
 176                 ex_nodes <- mapM (Container.findByName map_n) ex_names
 177                 let ex_ndx = map Node.idx ex_nodes
 178                 return $ Evacuate ex_ndx
 179           | optype == C.iallocatorModeMreloc ->
 180               do
 181                 rl_names <- extrReq "instances"
 182                 rl_insts <- mapM (Container.findByName map_i) rl_names
 183                 let rl_idx = map Instance.idx rl_insts
 184                 rl_mode <-
 185                    case extrReq "reloc_mode" of
 186                      Ok s | s == C.iallocatorMrelocKeep -> return KeepGroup
 187                           | s == C.iallocatorMrelocChange ->
 188                               do
 189                                 tg_groups <- parseTargetGroups request map_g
 190                                 return $ ChangeGroup tg_groups
 191                           | s == C.iallocatorMrelocAny -> return AnyGroup
 192                           | otherwise -> Bad $ "Invalid relocate mode " ++ s
 193                      Bad x -> Bad x
 194                 return $ MultiReloc rl_idx rl_mode
 195
 196           | otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
 197   return $ Request rqtype cdata
 198
 199 -- | Format the result
 200 formatRVal :: RqType -> [Node.AllocElement] -> JSValue
 201 formatRVal _ [] = JSArray []
 202
 203 formatRVal (Evacuate _) elems =
 204     let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl)
 205                elems
 206         jsols = map (JSArray . map (JSString . toJSString)) sols
 207     in JSArray jsols
 208
 209 formatRVal _ elems =
 210     let (_, _, nodes, _) = head elems
 211         nodes' = map Node.name nodes
 212     in JSArray $ map (JSString . toJSString) nodes'
 213
 214 -- | Formats the response into a valid IAllocator response message.
 215 formatResponse :: Bool     -- ^ Whether the request was successful
 216                -> String   -- ^ Information text
 217                -> RqType   -- ^ Request type
 218                -> [Node.AllocElement] -- ^ The resulting allocations
 219                -> String   -- ^ The JSON-formatted message
 220 formatResponse success info rq elems =
 221     let
 222         e_success = ("success", JSBool success)
 223         e_info = ("info", JSString . toJSString $ info)
 224         e_result = ("result", formatRVal rq elems)
 225     in encodeStrict $ makeObj [e_success, e_info, e_result]