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