X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/43643696384eb7d484aa64ba15c6e2e126b07543..b33a22437a1a0cae5a9a9d20b2e94905fcf344e4:/Ganeti/HTools/IAlloc.hs?ds=sidebyside diff --git a/Ganeti/HTools/IAlloc.hs b/Ganeti/HTools/IAlloc.hs index 483d6c9..b5391f6 100644 --- a/Ganeti/HTools/IAlloc.hs +++ b/Ganeti/HTools/IAlloc.hs @@ -11,134 +11,94 @@ module Ganeti.HTools.IAlloc import Data.Either () import Data.Maybe import Control.Monad -import Text.JSON +import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray), + makeObj, encodeStrict, decodeStrict, + fromJSObject, toJSString) import Text.Printf (printf) -import Ganeti.HTools.Utils () - - --- Some constants - -{-- Our cheap monad-like stuff. - -Thi is needed since Either e a is already a monad instance somewhere -in the standard libraries (Control.Monad.Error) and we don't need that -entire thing. - --} -combine :: (Either String a) -> (a -> Either String b) -> (Either String b) -combine (Left s) _ = Left s -combine (Right s) f = f s - -ensureList :: [Either String a] -> Either String [a] -ensureList lst = - foldr (\elem accu -> - case (elem, accu) of - (Left x, _) -> Left x - (_, Left x) -> Left x -- should never happen - (Right e, Right a) -> Right (e:a) - ) - (Right []) lst - -listHead :: Either String [a] -> Either String a -listHead lst = - case lst of - Left x -> Left x - Right (x:_) -> Right x - Right [] -> Left "List empty" - -loadJSArray :: String -> Either String [JSObject JSValue] -loadJSArray s = resultToEither $ decodeStrict s - -fromObj :: JSON a => String -> JSObject JSValue -> Either String a -fromObj k o = - case lookup k (fromJSObject o) of - Nothing -> Left $ printf "key '%s' not found" k - Just val -> resultToEither $ readJSON val - -getStringElement :: String -> JSObject JSValue -> Either String String -getStringElement = fromObj - -getIntElement :: String -> JSObject JSValue -> Either String Int -getIntElement = fromObj - -getListElement :: String -> JSObject JSValue - -> Either String [JSValue] -getListElement = fromObj - -readString :: JSValue -> Either String String -readString v = - case v of - JSString s -> Right $ fromJSString s - _ -> Left "Wrong JSON type" - -concatElems :: Either String String - -> Either String String - -> Either String String -concatElems = apply2 (\x y -> x ++ "|" ++ y) - -apply1 :: (a -> b) -> Either String a -> Either String b -apply1 fn a = - case a of - Left x -> Left x - Right y -> Right $ fn y - -apply2 :: (a -> b -> c) - -> Either String a - -> Either String b - -> Either String c -apply2 fn a b = - case (a, b) of - (Right x, Right y) -> Right $ fn x y - (Left x, _) -> Left x - (_, Left y) -> Left y - -parseList :: (JSObject JSValue -> Either String String) - -> [JSObject JSValue] - ->Either String String -parseList fn idata = - let ml = ensureList $ map fn idata - in ml `combine` (Right . unlines) - -parseInstance :: JSObject JSValue -> Either String String -parseInstance a = - let name = getStringElement "name" a +import Ganeti.HTools.Utils +import qualified Ganeti.HTools.Node as Node +import qualified Ganeti.HTools.Instance as Instance + +data RqType + = Allocate + | Relocate + deriving (Eq, Show) + +data Request + = RqAlloc String String String + | RqReloc String String String + +parseInstance :: String -> JSObject JSValue -> Result String +parseInstance n a = + let name = Ok n disk = case getIntElement "disk_usage" a of - Left _ -> let log_sz = apply2 (+) - (getIntElement "sda_size" a) - (getIntElement "sdb_size" a) - in apply2 (+) log_sz (Right $ 128 * 2) - Right x -> Right x - bep = fromObj "beparams" a - pnode = getStringElement "pnode" a - snode = (listHead $ getListElement "snodes" a) `combine` readString - mem = case bep of - Left _ -> getIntElement "admin_ram" a - Right o -> getIntElement "memory" o - running = getStringElement "status" a + Bad _ -> let all_d = getListElement "disks" a >>= asObjectList + szd = all_d >>= + (sequence . + map (getIntElement "size")) + sze = liftM (map (+128)) szd + szf = liftM sum sze + in szf + x@(Ok _) -> x + nodes = getListElement "nodes" a + pnode = liftM head nodes >>= readEitherString + snode = liftM (head . tail) nodes >>= readEitherString + mem = getIntElement "memory" a + running = Ok "running" --getStringElement "status" a in - concatElems name $ - concatElems (show `apply1` mem) $ - concatElems (show `apply1` disk) $ - concatElems running $ - concatElems pnode snode - -parseNode :: JSObject JSValue -> Either String String -parseNode a = - let name = getStringElement "name" a - mtotal = getIntElement "mtotal" a - mnode = getIntElement "mnode" a - mfree = getIntElement "mfree" a - dtotal = getIntElement "dtotal" a - dfree = getIntElement "dfree" a - in concatElems name $ - concatElems (show `apply1` mtotal) $ - concatElems (show `apply1` mnode) $ - concatElems (show `apply1` mfree) $ - concatElems (show `apply1` dtotal) (show `apply1` dfree) - -parseData :: String -> Maybe String + name |+ (show `liftM` mem) |+ + (show `liftM` disk) |+ running |+ pnode |+ snode + +parseNode :: String -> JSObject JSValue -> Result String +parseNode n a = + let name = Ok 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 name |+ (show `liftM` mtotal) |+ + (show `liftM` mnode) |+ + (show `liftM` mfree) |+ + (show `liftM` dtotal) |+ + (show `liftM` dfree) + +validateRequest :: String -> Result RqType +validateRequest rq = + case rq of + "allocate" -> Ok Allocate + "relocate" -> Ok Relocate + _ -> Bad ("Invalid request type '" ++ rq ++ "'") + +parseData :: String -> Result Request +parseData body = + do + decoded <- fromJResult $ decodeStrict body + let obj = decoded -- decoded `combineEithers` fromJSObject + -- request parser + request <- getObjectElement "request" obj + rname <- getStringElement "name" request + rtype <- getStringElement "type" request >>= validateRequest + inew <- (\x -> if x == Allocate then parseInstance rname request + else Ok "") rtype + -- existing intstance parsing + ilist <- getObjectElement "instances" obj + let idata = fromJSObject ilist + iobj <- (sequence . map (\(x,y) -> asJSObject y >>= parseInstance x)) + idata + let ilines = unlines iobj + -- existing node parsing + nlist <- getObjectElement "nodes" obj + let ndata = fromJSObject nlist + nobj <- (sequence . map (\(x,y) -> asJSObject y >>= parseNode x)) + ndata + let nlines = unlines nobj + return $ (\ r nl il inew rnam -> + case r of + Allocate -> RqAlloc inew nl il + Relocate -> RqReloc rnam nl il) + rtype nlines ilines inew rname -parseData x = Just x formatResponse :: Bool -> String -> [String] -> String formatResponse success info nodes =