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 <- 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 $ decodeStrict body
let obj = fromJSObject decoded
request <- liftM fromJSObject (fromObj "request" obj)
rname <- fromObj "name" request
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, csf) <- mergeData [] [] (nl, il, ctags)
req_nodes <- fromObj "required_nodes" request
optype <- fromObj "type" request
rqtype <-
case optype of
"allocate" ->
do
inew <- parseBaseInstance rname request
let io = snd inew
return $ Allocate io req_nodes
"relocate" ->
do
ridx <- lookupInstance kti rname
ex_nodes <- fromObj "relocate_from" request
let ex_nodes' = map (stripSuffix $ length csf) ex_nodes
ex_idex <- mapM (Container.findByName map_n) ex_nodes'
return $ Relocate ridx req_nodes (map Node.idx ex_idex)
other -> fail ("Invalid request type '" ++ other ++ "'")
return $ Request rqtype map_n map_i ptags csf
formatResponse :: Bool
-> String
-> [String]
-> String
formatResponse success info nodes =
let
e_success = ("success", JSBool success)
e_info = ("info", JSString . toJSString $ info)
e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes)
in encodeStrict $ makeObj [e_success, e_info, e_nodes]