module Ganeti.HTools.IAlloc
( parseData
, formatResponse
) where
import Data.Either ()
import Control.Monad
import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray),
makeObj, encodeStrict, decodeStrict,
fromJSObject, toJSString)
import qualified Ganeti.HTools.Container as Container
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Instance as Instance
import Ganeti.HTools.Loader
import Ganeti.HTools.Utils
import Ganeti.HTools.Types
parseBaseInstance :: String
-> [(String, JSValue)]
-> Result (String, Instance.Instance)
parseBaseInstance n a = do
disk <- fromObj "disk_space_total" a
mem <- fromObj "memory" a
vcpus <- fromObj "vcpus" a
tags <- fromObj "tags" a
let running = "running"
return (n, Instance.create n mem disk vcpus running tags 0 0)
parseInstance :: NameAssoc
-> String
-> [(String, JSValue)]
-> Result (String, Instance.Instance)
parseInstance ktn n a = do
base <- parseBaseInstance n a
nodes <- fromObj "nodes" a
pnode <- if null nodes
then Bad $ "empty node list for instance " ++ n
else readEitherString $ head nodes
pidx <- lookupNode ktn n pnode
let snodes = tail nodes
sidx <- (if null snodes then return Node.noSecondary
else readEitherString (head snodes) >>= lookupNode ktn n)
return (n, Instance.setBoth (snd base) pidx sidx)
parseNode :: String
-> [(String, JSValue)]
-> Result (String, Node.Node)
parseNode n a = do
offline <- fromObj "offline" a
drained <- fromObj "drained" a
node <- (if offline || drained
then return $ Node.create n 0 0 0 0 0 0 True
else do
mtotal <- fromObj "total_memory" a
mnode <- fromObj "reserved_memory" a
mfree <- fromObj "free_memory" a
dtotal <- fromObj "total_disk" a
dfree <- fromObj "free_disk" a
ctotal <- fromObj "total_cpus" a
return $ Node.create n mtotal mnode mfree
dtotal dfree ctotal False)
return (n, node)
parseData :: String
-> Result Request
parseData body = do
decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
let obj = fromJSObject decoded
request <- liftM fromJSObject (fromObj "request" obj)
nlist <- liftM fromJSObject (fromObj "nodes" obj)
nobj <- mapM (\(x,y) -> asJSObject y >>= parseNode x . fromJSObject) nlist
let (ktn, nl) = assignIndices nobj
ilist <- fromObj "instances" obj
let idata = fromJSObject ilist
iobj <- mapM (\(x,y) ->
asJSObject y >>= parseInstance ktn x . fromJSObject) idata
let (kti, il) = assignIndices iobj
ctags <- fromObj "cluster_tags" obj
(map_n, map_i, ptags) <- mergeData [] [] [] (nl, il, ctags)
optype <- fromObj "type" request
rqtype <-
case optype of
"allocate" ->
do
rname <- fromObj "name" request
req_nodes <- fromObj "required_nodes" request
inew <- parseBaseInstance rname request
let io = snd inew
return $ Allocate io req_nodes
"relocate" ->
do
rname <- fromObj "name" request
ridx <- lookupInstance kti rname
req_nodes <- fromObj "required_nodes" request
ex_nodes <- fromObj "relocate_from" request
ex_idex <- mapM (Container.findByName map_n) ex_nodes
return $ Relocate ridx req_nodes (map Node.idx ex_idex)
"multi-evacuate" ->
do
ex_names <- fromObj "evac_nodes" request
ex_nodes <- mapM (Container.findByName map_n) ex_names
let ex_ndx = map Node.idx ex_nodes
return $ Evacuate ex_ndx
other -> fail ("Invalid request type '" ++ other ++ "'")
return $ Request rqtype map_n map_i ptags
formatRVal :: RqType -> [Node.AllocElement] -> JSValue
formatRVal _ [] = JSArray []
formatRVal (Evacuate _) elems =
let sols = map (\(_, inst, nl) -> Instance.name inst : map Node.name nl)
elems
jsols = map (JSArray . map (JSString . toJSString)) sols
in JSArray jsols
formatRVal _ elems =
let (_, _, nodes) = head elems
nodes' = map Node.name nodes
in JSArray $ map (JSString . toJSString) nodes'
formatResponse :: Bool
-> String
-> RqType
-> [Node.AllocElement]
-> String
formatResponse success info rq elems =
let
e_success = ("success", JSBool success)
e_info = ("info", JSString . toJSString $ info)
e_nodes = ("nodes", formatRVal rq elems)
in encodeStrict $ makeObj [e_success, e_info, e_nodes]