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