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 <- (case offline of
  82                True -> return $ Node.create name 0 0 0 0 0 True
  83                _ -> 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                  return $ Node.create n mtotal mnode mfree
  90                         dtotal dfree (offline || drained))
  91     return (name, node)
  92
  93 -- | Top-level parser.
  94 parseData :: String         -- ^ The JSON message as received from Ganeti
  95           -> Result Request -- ^ A (possible valid) request
  96 parseData body = do
  97   decoded <- fromJResult $ decodeStrict body
  98   let obj = decoded
  99   -- request parser
 100   request <- fromObj "request" obj
 101   rname <- fromObj "name" request
 102   -- existing node parsing
 103   nlist <- fromObj "nodes" obj
 104   let ndata = fromJSObject nlist
 105   nobj <- (mapM (\(x,y) -> asJSObject y >>= parseNode x)) ndata
 106   let (ktn, nl) = assignIndices nobj
 107   -- existing instance parsing
 108   ilist <- fromObj "instances" obj
 109   let idata = fromJSObject ilist
 110   iobj <- (mapM (\(x,y) -> asJSObject y >>= parseInstance ktn x)) idata
 111   let (kti, il) = assignIndices iobj
 112   (map_n, map_i, csf) <- mergeData (nl, il)
 113   req_nodes <- fromObj "required_nodes" request
 114   optype <- fromObj "type" request
 115   rqtype <-
 116       case optype of
 117         "allocate" ->
 118             do
 119               inew <- parseBaseInstance rname request
 120               let io = snd inew
 121               return $ Allocate io req_nodes
 122         "relocate" ->
 123             do
 124               ridx <- lookupInstance kti rname
 125               ex_nodes <- fromObj "relocate_from" request
 126               let ex_nodes' = map (stripSuffix $ length csf) ex_nodes
 127               ex_idex <- mapM (Container.findByName map_n) ex_nodes'
 128               return $ Relocate ridx req_nodes ex_idex
 129         other -> fail $ ("Invalid request type '" ++ other ++ "'")
 130   return $ Request rqtype map_n map_i csf
 131
 132 -- | Formats the response into a valid IAllocator response message.
 133 formatResponse :: Bool     -- ^ Whether the request was successful
 134                -> String   -- ^ Information text
 135                -> [String] -- ^ The list of chosen nodes
 136                -> String   -- ^ The JSON-formatted message
 137 formatResponse success info nodes =
 138     let
 139         e_success = ("success", JSBool success)
 140         e_info = ("info", JSString . toJSString $ info)
 141         e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
 142     in encodeStrict $ makeObj [e_success, e_info, e_nodes]