code.grnet.gr Git - ganeti-local/blob - Ganeti/HTools/IAlloc.hs

   1 {-| Implementation of the iallocator interface.
   2
   3 -}
   4
   5 {-
   6
   7 Copyright (C) 2009 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 Control.Monad
  33 import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
  34                   makeObj, encodeStrict, decodeStrict,
  35                   fromJSObject, toJSString)
  36 import qualified Ganeti.HTools.Container as Container
  37 import qualified Ganeti.HTools.Node as Node
  38 import qualified Ganeti.HTools.Instance as Instance
  39 import Ganeti.HTools.Loader
  40 import Ganeti.HTools.Utils
  41 import Ganeti.HTools.Types
  42
  43 -- | Parse the basic specifications of an instance.
  44 --
  45 -- Instances in the cluster instance list and the instance in an
  46 -- 'Allocate' request share some common properties, which are read by
  47 -- this function.
  48 parseBaseInstance :: String
  49                   -> JSObject JSValue
  50                   -> Result (String, Instance.Instance)
  51 parseBaseInstance n a = do
  52   disk <- fromObj "disk_space_total" a
  53   mem <- fromObj "memory" a
  54   vcpus <- fromObj "vcpus" a
  55   let running = "running"
  56   return (n, Instance.create n mem disk vcpus running 0 0)
  57
  58 -- | Parses an instance as found in the cluster instance list.
  59 parseInstance :: NameAssoc        -- ^ The node name-to-index association list
  60               -> String           -- ^ The name of the instance
  61               -> JSObject JSValue -- ^ The JSON object
  62               -> Result (String, Instance.Instance)
  63 parseInstance ktn n a = do
  64     base <- parseBaseInstance n a
  65     nodes <- fromObj "nodes" a
  66     pnode <- readEitherString $ head nodes
  67     pidx <- lookupNode ktn n pnode
  68     let snodes = tail nodes
  69     sidx <- (if null snodes then return Node.noSecondary
  70              else readEitherString (head snodes) >>= lookupNode ktn n)
  71     return (n, Instance.setBoth (snd base) pidx sidx)
  72
  73 -- | Parses a node as found in the cluster node list.
  74 parseNode :: String           -- ^ The node's name
  75           -> JSObject JSValue -- ^ The JSON object
  76           -> Result (String, Node.Node)
  77 parseNode n a = do
  78     let name = n
  79     offline <- fromObj "offline" a
  80     drained <- fromObj "drained" a
  81     node <- (if offline || drained
  82              then return $ Node.create name 0 0 0 0 0 0 True
  83              else do
  84                mtotal <- fromObj "total_memory" a
  85                mnode  <- fromObj "reserved_memory" a
  86                mfree  <- fromObj "free_memory"  a
  87                dtotal <- fromObj "total_disk"   a
  88                dfree  <- fromObj "free_disk"    a
  89                ctotal <- fromObj "total_cpus"   a
  90                return $ Node.create n mtotal mnode mfree
  91                       dtotal dfree ctotal False)
  92     return (name, node)
  93
  94 -- | Top-level parser.
  95 parseData :: String         -- ^ The JSON message as received from Ganeti
  96           -> Result Request -- ^ A (possible valid) request
  97 parseData body = do
  98   decoded <- fromJResult $ decodeStrict body
  99   let obj = decoded
 100   -- request parser
 101   request <- fromObj "request" obj
 102   rname <- fromObj "name" request
 103   -- existing node parsing
 104   nlist <- fromObj "nodes" obj
 105   let ndata = fromJSObject nlist
 106   nobj <- mapM (\(x,y) -> asJSObject y >>= parseNode x) ndata
 107   let (ktn, nl) = assignIndices nobj
 108   -- existing instance parsing
 109   ilist <- fromObj "instances" obj
 110   let idata = fromJSObject ilist
 111   iobj <- mapM (\(x,y) -> asJSObject y >>= parseInstance ktn x) idata
 112   let (kti, il) = assignIndices iobj
 113   (map_n, map_i, csf) <- mergeData [] (nl, il)
 114   req_nodes <- fromObj "required_nodes" request
 115   optype <- fromObj "type" request
 116   rqtype <-
 117       case optype of
 118         "allocate" ->
 119             do
 120               inew <- parseBaseInstance rname request
 121               let io = snd inew
 122               return $ Allocate io req_nodes
 123         "relocate" ->
 124             do
 125               ridx <- lookupInstance kti rname
 126               ex_nodes <- fromObj "relocate_from" request
 127               let ex_nodes' = map (stripSuffix $ length csf) ex_nodes
 128               ex_idex <- mapM (Container.findByName map_n) ex_nodes'
 129               return $ Relocate ridx req_nodes (map Node.idx ex_idex)
 130         other -> fail ("Invalid request type '" ++ other ++ "'")
 131   return $ Request rqtype map_n map_i csf
 132
 133 -- | Formats the response into a valid IAllocator response message.
 134 formatResponse :: Bool     -- ^ Whether the request was successful
 135                -> String   -- ^ Information text
 136                -> [String] -- ^ The list of chosen nodes
 137                -> String   -- ^ The JSON-formatted message
 138 formatResponse success info nodes =
 139     let
 140         e_success = ("success", JSBool success)
 141         e_info = ("info", JSString . toJSString $ info)
 142         e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
 143     in encodeStrict $ makeObj [e_success, e_info, e_nodes]