X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/2727257a27e09454035b07ca376d89aec7a39e14..cf924b6d3f9fd1e1b95cf5cda8a38e077a5de7a9:/Ganeti/HTools/IAlloc.hs diff --git a/Ganeti/HTools/IAlloc.hs b/Ganeti/HTools/IAlloc.hs index f6a2733..801243b 100644 --- a/Ganeti/HTools/IAlloc.hs +++ b/Ganeti/HTools/IAlloc.hs @@ -2,76 +2,98 @@ -} +{- + +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 (JSObject, JSValue(JSBool, JSString, JSArray), makeObj, encodeStrict, decodeStrict, fromJSObject, toJSString) ---import Text.Printf (printf) +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 String Instance.Instance - | Relocate Int - deriving (Show) - -data Request = Request RqType IdxNode IdxInstance NameList NameList - deriving (Show) - +-- | 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 -> JSObject JSValue -> Result (String, Instance.Instance) parseBaseInstance n a = do - disk <- case fromObj "disk_usage" a of - Bad _ -> do - all_d <- fromObj "disks" a >>= asObjectList - szd <- mapM (fromObj "size") all_d - let sze = map (+128) szd - szf = (sum sze)::Int - return szf - x@(Ok _) -> x + disk <- fromObj "disk_space_total" a mem <- fromObj "memory" a + vcpus <- fromObj "vcpus" a let running = "running" - return $ (n, Instance.create n mem disk running 0 0) + return (n, Instance.create n mem disk vcpus running 0 0) -parseInstance :: NameAssoc - -> String - -> JSObject JSValue +-- | Parses an instance as found in the cluster instance list. +parseInstance :: NameAssoc -- ^ The node name-to-index association list + -> String -- ^ The name of the instance + -> JSObject JSValue -- ^ The JSON object -> Result (String, Instance.Instance) parseInstance ktn n a = do base <- parseBaseInstance n a nodes <- fromObj "nodes" a pnode <- readEitherString $ head nodes - snode <- readEitherString $ (head . tail) nodes pidx <- lookupNode ktn n pnode - sidx <- lookupNode ktn n snode + 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 -> JSObject JSValue -> Result (String, Node.Node) +-- | Parses a node as found in the cluster node list. +parseNode :: String -- ^ The node's name + -> JSObject JSValue -- ^ The JSON object + -> Result (String, Node.Node) parseNode n a = do let name = n - 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 offline <- fromObj "offline" a - drained <- fromObj "offline" a - return $ (name, Node.create n mtotal mnode mfree dtotal dfree - (offline || drained)) + drained <- fromObj "drained" a + node <- (if offline + then return $ Node.create name 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 (offline || drained)) + return (name, node) -parseData :: String -> Result Request +-- | Top-level parser. +parseData :: String -- ^ The JSON message as received from Ganeti + -> Result Request -- ^ A (possible valid) request parseData body = do decoded <- fromJResult $ decodeStrict body let obj = decoded @@ -81,30 +103,38 @@ parseData body = do -- existing node parsing nlist <- fromObj "nodes" obj let ndata = fromJSObject nlist - nobj <- (mapM (\(x,y) -> asJSObject y >>= parseNode x)) ndata - let (ktn, nl) = assignIndices Node.setIdx nobj + nobj <- mapM (\(x,y) -> asJSObject y >>= parseNode x) ndata + 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)) idata - let (kti, il) = assignIndices Instance.setIdx iobj + iobj <- mapM (\(x,y) -> asJSObject y >>= parseInstance ktn x) idata + let (kti, il) = assignIndices iobj + (map_n, map_i, csf) <- mergeData (nl, il) + req_nodes <- fromObj "required_nodes" request optype <- fromObj "type" request rqtype <- case optype of "allocate" -> do inew <- parseBaseInstance rname request - let (iname, io) = inew - return $ Allocate iname io + let io = snd inew + return $ Allocate io req_nodes "relocate" -> do - ridx <- lookupNode kti rname rname - return $ Relocate ridx - other -> fail $ ("Invalid request type '" ++ other ++ "'") - - return $ Request rqtype nl il (swapPairs ktn) (swapPairs kti) + 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 ex_idex + other -> fail ("Invalid request type '" ++ other ++ "'") + return $ Request rqtype map_n map_i csf -formatResponse :: Bool -> String -> [String] -> String +-- | Formats the response into a valid IAllocator response message. +formatResponse :: Bool -- ^ Whether the request was successful + -> String -- ^ Information text + -> [String] -- ^ The list of chosen nodes + -> String -- ^ The JSON-formatted message formatResponse success info nodes = let e_success = ("success", JSBool success)