X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/144f190b60b71c1abd52e41aad1ccfae95bf371f..99b63608c593b37bead28376777fa95e49825a51:/Ganeti/HTools/IAlloc.hs diff --git a/Ganeti/HTools/IAlloc.hs b/Ganeti/HTools/IAlloc.hs index d993c13..d0bfec6 100644 --- a/Ganeti/HTools/IAlloc.hs +++ b/Ganeti/HTools/IAlloc.hs @@ -2,105 +2,170 @@ -} +{- + +Copyright (C) 2009 Google Inc. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA. + +-} + module Ganeti.HTools.IAlloc - ( - parseData + ( parseData , formatResponse ) where import Data.Either () -import Data.Maybe import Control.Monad -import Text.JSON -import Text.Printf (printf) +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 -data RqType - = Allocate - | Relocate - deriving (Show) - -parseInstance :: String -> JSObject JSValue -> Either String String -parseInstance n a = - let name = Right n - disk = case getIntElement "disk_usage" a of - Left _ -> let all_d = getListElement "disks" a `combineEithers` - asObjectList - szd = all_d `combineEithers` - (ensureEitherList . - map (getIntElement "size")) - sze = applyEither1 (map (+128)) szd - szf = applyEither1 sum sze - in szf - Right x -> Right x - nodes = getListElement "nodes" a - pnode = eitherListHead nodes - `combineEithers` readEitherString - snode = applyEither1 (head . tail) nodes - `combineEithers` readEitherString - mem = getIntElement "memory" a - running = Right "running" --getStringElement "status" a - in - concatEitherElems name $ - concatEitherElems (show `applyEither1` mem) $ - concatEitherElems (show `applyEither1` disk) $ - concatEitherElems running $ - concatEitherElems pnode snode - -parseNode :: String -> JSObject JSValue -> Either String String -parseNode n a = - let name = Right n - mtotal = getIntElement "total_memory" a - mnode = getIntElement "reserved_memory" a - mfree = getIntElement "free_memory" a - dtotal = getIntElement "total_disk" a - dfree = getIntElement "free_disk" a - in concatEitherElems name $ - concatEitherElems (show `applyEither1` mtotal) $ - concatEitherElems (show `applyEither1` mnode) $ - concatEitherElems (show `applyEither1` mfree) $ - concatEitherElems (show `applyEither1` dtotal) - (show `applyEither1` dfree) - -validateRequest :: String -> Either String RqType -validateRequest rq = - case rq of - "allocate" -> Right Allocate - "relocate" -> Right Relocate - _ -> Left ("Invalid request type '" ++ rq ++ "'") - -parseData :: String -> Either String (String, String) -parseData body = - let - decoded = resultToEither $ decodeStrict body - obj = decoded -- decoded `combineEithers` fromJSObject - -- request parser - request = obj `combineEithers` getObjectElement "request" - rname = request `combineEithers` getStringElement "name" - rtype = request `combineEithers` getStringElement "type" - `combineEithers` validateRequest - -- existing intstance parsing - ilist = obj `combineEithers` getObjectElement "instances" - idata = applyEither1 fromJSObject ilist - iobj = idata `combineEithers` (ensureEitherList . - map (\(x,y) -> - asJSObject y `combineEithers` - parseInstance x)) - ilines = iobj `combineEithers` (Right . unlines) - -- existing node parsing - nlist = obj `combineEithers` getObjectElement "nodes" - ndata = applyEither1 fromJSObject nlist - nobj = ndata `combineEithers` (ensureEitherList . - map (\(x,y) -> - asJSObject y `combineEithers` - parseNode x)) - nlines = nobj `combineEithers` (Right . unlines) - in applyEither2 (,) nlines ilines - -formatResponse :: Bool -> String -> [String] -> String -formatResponse success info nodes = +-- | Parse the basic specifications of an instance. +-- +-- Instances in the cluster instance list and the instance in an +-- 'Allocate' request share some common properties, which are read by +-- this function. +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) + +-- | Parses an instance as found in the cluster instance listg. +parseInstance :: NameAssoc -- ^ The node name-to-index association list + -> String -- ^ The name of the instance + -> [(String, JSValue)] -- ^ The JSON object + -> 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) + +-- | Parses a node as found in the cluster node list. +parseNode :: String -- ^ The node's name + -> [(String, JSValue)] -- ^ The JSON object + -> Result (String, Node.Node) +parseNode n a = do + offline <- fromObj "offline" a + drained <- fromObj "drained" a + guuid <- fromObj "group" a + node <- (if offline || drained + then return $ Node.create n 0 0 0 0 0 0 True guuid + 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 guuid) + return (n, node) + +-- | Top-level parser. +parseData :: String -- ^ The JSON message as received from Ganeti + -> Result Request -- ^ A (possible valid) request +parseData body = do + decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body) + let obj = fromJSObject decoded + -- request parser + request <- liftM fromJSObject (fromObj "request" obj) + -- existing node parsing + nlist <- liftM fromJSObject (fromObj "nodes" obj) + nobj <- mapM (\(x,y) -> asJSObject y >>= parseNode x . fromJSObject) nlist + let (ktn, nl) = assignIndices nobj + -- existing instance parsing + ilist <- fromObj "instances" obj + let idata = fromJSObject ilist + iobj <- mapM (\(x,y) -> + asJSObject y >>= parseInstance ktn x . fromJSObject) idata + let (kti, il) = assignIndices iobj + -- cluster tags + 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 + +-- | Format the result +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' + +-- | Formats the response into a valid IAllocator response message. +formatResponse :: Bool -- ^ Whether the request was successful + -> String -- ^ Information text + -> RqType -- ^ Request type + -> [Node.AllocElement] -- ^ The resulting allocations + -> String -- ^ The JSON-formatted message +formatResponse success info rq elems = let e_success = ("success", JSBool success) e_info = ("info", JSString . toJSString $ info) - e_nodes = ("nodes", JSArray $ map (JSString . toJSString) nodes) + e_nodes = ("nodes", formatRVal rq elems) in encodeStrict $ makeObj [e_success, e_info, e_nodes]