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

   1 {-| Implementation of the iallocator interface.
   2
   3 -}
   4
   5 module Ganeti.HTools.IAlloc
   6     (
   7       parseData
   8     , formatResponse
   9     ) where
  10
  11 import Data.Either ()
  12 --import Data.Maybe
  13 import Control.Monad
  14 import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
  15                   makeObj, encodeStrict, decodeStrict,
  16                   fromJSObject, toJSString)
  17 --import Text.Printf (printf)
  18 import qualified Ganeti.HTools.Node as Node
  19 import qualified Ganeti.HTools.Instance as Instance
  20 import Ganeti.HTools.Loader
  21 import Ganeti.HTools.Utils
  22 import Ganeti.HTools.Types
  23
  24 data RqType
  25     = Allocate String Instance.Instance
  26     | Relocate Int
  27     deriving (Show)
  28
  29 data Request = Request RqType NodeList InstanceList String NameList NameList
  30     deriving (Show)
  31
  32 parseBaseInstance :: String
  33                   -> JSObject JSValue
  34                   -> Result (String, Instance.Instance)
  35 parseBaseInstance n a = do
  36   disk <- case fromObj "disk_usage" a of
  37             Bad _ -> do
  38                 all_d <- fromObj "disks" a >>= asObjectList
  39                 szd <- mapM (fromObj "size") all_d
  40                 let sze = map (+128) szd
  41                     szf = (sum sze)::Int
  42                 return szf
  43             x@(Ok _) -> x
  44   mem <- fromObj "memory" a
  45   let running = "running"
  46   return $ (n, Instance.create n mem disk running 0 0)
  47
  48 parseInstance :: NameAssoc
  49               -> String
  50               -> JSObject JSValue
  51               -> Result (String, Instance.Instance)
  52 parseInstance ktn n a = do
  53     base <- parseBaseInstance n a
  54     nodes <- fromObj "nodes" a
  55     pnode <- readEitherString $ head nodes
  56     snode <- readEitherString $ (head . tail) nodes
  57     pidx <- lookupNode ktn n pnode
  58     sidx <- lookupNode ktn n snode
  59     return (n, Instance.setBoth (snd base) pidx sidx)
  60
  61 parseNode :: String -> JSObject JSValue -> Result (String, Node.Node)
  62 parseNode n a = do
  63     let name = n
  64     mtotal <- fromObj "total_memory" a
  65     mnode <- fromObj "reserved_memory" a
  66     mfree <- fromObj "free_memory" a
  67     dtotal <- fromObj "total_disk" a
  68     dfree <- fromObj "free_disk" a
  69     offline <- fromObj "offline" a
  70     drained <- fromObj "offline" a
  71     return $ (name, Node.create n mtotal mnode mfree dtotal dfree
  72                       (offline || drained))
  73
  74 parseData :: String -> Result Request
  75 parseData body = do
  76   decoded <- fromJResult $ decodeStrict body
  77   let obj = decoded
  78   -- request parser
  79   request <- fromObj "request" obj
  80   rname <- fromObj "name" request
  81   -- existing node parsing
  82   nlist <- fromObj "nodes" obj
  83   let ndata = fromJSObject nlist
  84   nobj <- (mapM (\(x,y) -> asJSObject y >>= parseNode x)) ndata
  85   let (ktn, nl) = assignIndices nobj
  86   -- existing instance parsing
  87   ilist <- fromObj "instances" obj
  88   let idata = fromJSObject ilist
  89   iobj <- (mapM (\(x,y) -> asJSObject y >>= parseInstance ktn x)) idata
  90   let (kti, il) = assignIndices iobj
  91   optype <- fromObj "type" request
  92   rqtype <-
  93       case optype of
  94         "allocate" ->
  95             do
  96               inew <- parseBaseInstance rname request
  97               let (iname, io) = inew
  98               return $ Allocate iname io
  99         "relocate" ->
 100             do
 101               ridx <- lookupNode kti rname rname
 102               return $ Relocate ridx
 103         other -> fail $ ("Invalid request type '" ++ other ++ "'")
 104   (map_n, map_i, csf, xtn, xti) <- mergeData (ktn, nl, kti, il)
 105   return $ Request rqtype map_n map_i csf xtn xti
 106
 107 formatResponse :: Bool -> String -> [String] -> String
 108 formatResponse success info nodes =
 109     let
 110         e_success = ("success", JSBool success)
 111         e_info = ("info", JSString . toJSString $ info)
 112         e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
 113     in encodeStrict $ makeObj [e_success, e_info, e_nodes]