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