From e4c5beaf3ee5cf16fd40573e3afe9a708b58bb4f Mon Sep 17 00:00:00 2001 From: Iustin Pop <iustin@google.com> Date: Sat, 23 May 2009 00:18:50 +0100 Subject: [PATCH] More code reorganizations This new big patch does a couple of more cleanups in the loading of data chapter: - introduce a Types module that holds most types (except the base Node/Instance/etc.) so that multiple other modules can use these (instead of only Cluster and its users) - bring IAlloc.hs in line with the recent changes of providing data types and not strings - removal of obsolete Utils.hs json-related functions --- Ganeti/HTools/Cluster.hs | 72 +----------------- Ganeti/HTools/IAlloc.hs | 155 +++++++++++++++++++-------------------- Ganeti/HTools/Loader.hs | 79 +++++++++++++++++++- Ganeti/HTools/Node.hs | 2 - Ganeti/HTools/Rapi.hs | 3 +- Ganeti/HTools/Text.hs | 1 + Ganeti/HTools/Types.hs | 41 +++++++++++ Ganeti/HTools/Utils.hs | 54 +------------- hail.hs | 1 + hbal.hs | 4 +- hn1.hs | 7 +- hscan.hs | 5 +- 12 files changed, 212 insertions(+), 212 deletions(-) create mode 100644 Ganeti/HTools/Types.hs diff --git a/Ganeti/HTools/Cluster.hs b/Ganeti/HTools/Cluster.hs index cba2ad0f3..33d523c69 100644 --- a/Ganeti/HTools/Cluster.hs +++ b/Ganeti/HTools/Cluster.hs @@ -32,7 +32,6 @@ module Ganeti.HTools.Cluster , compCV , printStats -- * Loading functions - , loadData , checkData ) where @@ -45,12 +44,9 @@ import Control.Monad import qualified Ganeti.HTools.Container as Container import qualified Ganeti.HTools.Instance as Instance import qualified Ganeti.HTools.Node as Node +import Ganeti.HTools.Types import Ganeti.HTools.Utils -type NodeList = Container.Container Node.Node -type InstanceList = Container.Container Instance.Instance --- | The type used to hold idx-to-name mappings -type NameList = [(Int, String)] -- | A separate name for the cluster score type type Score = Double @@ -690,72 +686,6 @@ printStats nl = -- Loading functions --- | For each instance, add its index to its primary and secondary nodes -fixNodes :: [(Int, Node.Node)] - -> [(Int, Instance.Instance)] - -> [(Int, Node.Node)] -fixNodes nl il = - foldl' (\accu (idx, inst) -> - let - assocEqual = (\ (i, _) (j, _) -> i == j) - pdx = Instance.pnode inst - sdx = Instance.snode inst - pold = fromJust $ lookup pdx accu - pnew = Node.setPri pold idx - ac1 = deleteBy assocEqual (pdx, pold) accu - ac2 = (pdx, pnew):ac1 - in - if sdx /= Node.noSecondary then - let - sold = fromJust $ lookup sdx accu - snew = Node.setSec sold idx - ac3 = deleteBy assocEqual (sdx, sold) ac2 - ac4 = (sdx, snew):ac3 - in ac4 - else - ac2 - ) nl il - --- | Compute the longest common suffix of a NameList list that --- | starts with a dot -longestDomain :: NameList -> String -longestDomain [] = "" -longestDomain ((_,x):xs) = - let - onlyStrings = snd $ unzip xs - in - foldr (\ suffix accu -> if all (isSuffixOf suffix) onlyStrings - then suffix - else accu) - "" $ filter (isPrefixOf ".") (tails x) - --- | Remove tails from the (Int, String) lists -stripSuffix :: String -> NameList -> NameList -stripSuffix suffix lst = - let sflen = length suffix in - map (\ (key, name) -> (key, take ((length name) - sflen) name)) lst - - -{-| Initializer function that loads the data from a node and list file - and massages it into the correct format. -} -loadData :: ([(String, Int)], Node.AssocList, - [(String, Int)], Instance.AssocList) -- ^ Data from either - -- Text.loadData - -- or Rapi.loadData - -> Result (NodeList, InstanceList, String, NameList, NameList) -loadData (ktn, nl, kti, il) = do - let - nl2 = fixNodes nl il - il3 = Container.fromAssocList il - nl3 = Container.fromAssocList - (map (\ (k, v) -> (k, Node.buildPeers v il3 (length nl2))) nl2) - xtn = swapPairs ktn - xti = swapPairs kti - common_suffix = longestDomain (xti ++ xtn) - stn = stripSuffix common_suffix xtn - sti = stripSuffix common_suffix xti - return (nl3, il3, common_suffix, stn, sti) - -- | Compute the amount of memory used by primary instances on a node. nodeImem :: Node.Node -> InstanceList -> Int nodeImem node il = diff --git a/Ganeti/HTools/IAlloc.hs b/Ganeti/HTools/IAlloc.hs index a494cd7b1..76776e7c5 100644 --- a/Ganeti/HTools/IAlloc.hs +++ b/Ganeti/HTools/IAlloc.hs @@ -15,97 +15,94 @@ import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray), makeObj, encodeStrict, decodeStrict, fromJSObject, toJSString) --import Text.Printf (printf) -import Ganeti.HTools.Utils 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 (Eq, Show) + = Allocate String Instance.Instance + | Relocate Int + deriving (Show) -data Request - = RqAlloc String String String - | RqReloc String String String +data Request = Request RqType IdxNode IdxInstance NameList NameList deriving (Show) -parseBaseInstance :: String -> JSObject JSValue -> Result String -parseBaseInstance n a = - let name = Ok n - disk = case getIntElement "disk_usage" a of - 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 - mem = getIntElement "memory" a - running = Ok "running" --getStringElement "status" a - in - name |+ (show `liftM` mem) |+ - (show `liftM` disk) |+ running +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 + mem <- fromObj "memory" a + let running = "running" + return $ (n, Instance.create mem disk running 0 0) -parseInstance :: String -> JSObject JSValue -> Result String -parseInstance n a = do +parseInstance :: NameAssoc + -> String + -> JSObject JSValue + -> Result (String, Instance.Instance) +parseInstance ktn n a = do base <- parseBaseInstance n a - let - nodes = getListElement "nodes" a - pnode = liftM head nodes >>= readEitherString - snode = liftM (head . tail) nodes >>= readEitherString - return base |+ pnode |+ snode + nodes <- fromObj "nodes" a + pnode <- readEitherString $ head nodes + snode <- readEitherString $ (head . tail) nodes + pidx <- lookupNode ktn n pnode + sidx <- lookupNode ktn n snode + return (n, Instance.setBoth (snd base) pidx sidx) - -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 ++ "'") +parseNode :: String -> JSObject JSValue -> 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 mtotal mnode mfree dtotal dfree + (offline || drained)) parseData :: String -> Result Request -parseData body = - do - decoded <- fromJResult $ decodeStrict body - let obj = decoded - -- request parser - request <- getObjectElement "request" obj - rname <- getStringElement "name" request - rtype <- getStringElement "type" request >>= validateRequest - inew <- (\x -> if x == Allocate then parseBaseInstance rname request - else Ok "") rtype - -- existing instance 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 body = do + decoded <- fromJResult $ decodeStrict body + let obj = decoded + -- request parser + request <- fromObj "request" obj + rname <- fromObj "name" request + -- 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 + -- 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 + optype <- fromObj "type" request + rqtype <- + case optype of + "allocate" -> + do + inew <- parseBaseInstance rname request + let (iname, io) = inew + return $ Allocate iname io + "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) formatResponse :: Bool -> String -> [String] -> String formatResponse success info nodes = diff --git a/Ganeti/HTools/Loader.hs b/Ganeti/HTools/Loader.hs index 0363db5bd..11f73b532 100644 --- a/Ganeti/HTools/Loader.hs +++ b/Ganeti/HTools/Loader.hs @@ -7,7 +7,19 @@ This module holds the common code for loading the cluster state from external so module Ganeti.HTools.Loader where -type NameAssoc = [(String, Int)] +import Data.List +import Data.Maybe (isNothing, fromJust) + +import qualified Ganeti.HTools.Container as Container +import qualified Ganeti.HTools.Instance as Instance +import qualified Ganeti.HTools.Node as Node + +import Ganeti.HTools.Types + + +-- | Swap a list of @(a, b)@ into @(b, a)@ +swapPairs :: [(a, b)] -> [(b, a)] +swapPairs = map (\ (a, b) -> (b, a)) -- | Lookups a node into an assoc list lookupNode :: (Monad m) => NameAssoc -> String -> String -> m Int @@ -22,3 +34,68 @@ assignIndices :: (a -> Int -> a) assignIndices set_fn = unzip . map (\ (idx, (k, v)) -> ((k, idx), (idx, set_fn v idx))) . zip [0..] + +-- | For each instance, add its index to its primary and secondary nodes +fixNodes :: [(Int, Node.Node)] + -> [(Int, Instance.Instance)] + -> [(Int, Node.Node)] +fixNodes nl il = + foldl' (\accu (idx, inst) -> + let + assocEqual = (\ (i, _) (j, _) -> i == j) + pdx = Instance.pnode inst + sdx = Instance.snode inst + pold = fromJust $ lookup pdx accu + pnew = Node.setPri pold idx + ac1 = deleteBy assocEqual (pdx, pold) accu + ac2 = (pdx, pnew):ac1 + in + if sdx /= Node.noSecondary then + let + sold = fromJust $ lookup sdx accu + snew = Node.setSec sold idx + ac3 = deleteBy assocEqual (sdx, sold) ac2 + ac4 = (sdx, snew):ac3 + in ac4 + else + ac2 + ) nl il + +-- | Compute the longest common suffix of a NameList list that +-- | starts with a dot +longestDomain :: NameList -> String +longestDomain [] = "" +longestDomain ((_,x):xs) = + let + onlyStrings = snd $ unzip xs + in + foldr (\ suffix accu -> if all (isSuffixOf suffix) onlyStrings + then suffix + else accu) + "" $ filter (isPrefixOf ".") (tails x) + +-- | Remove tails from the (Int, String) lists +stripSuffix :: String -> NameList -> NameList +stripSuffix suffix lst = + let sflen = length suffix in + map (\ (key, name) -> (key, take ((length name) - sflen) name)) lst + +{-| Initializer function that loads the data from a node and list file + and massages it into the correct format. -} +mergeData :: ([(String, Int)], Node.AssocList, + [(String, Int)], Instance.AssocList) -- ^ Data from either + -- Text.loadData + -- or Rapi.loadData + -> Result (NodeList, InstanceList, String, NameList, NameList) +mergeData (ktn, nl, kti, il) = do + let + nl2 = fixNodes nl il + il3 = Container.fromAssocList il + nl3 = Container.fromAssocList + (map (\ (k, v) -> (k, Node.buildPeers v il3 (length nl2))) nl2) + xtn = swapPairs ktn + xti = swapPairs kti + common_suffix = longestDomain (xti ++ xtn) + stn = stripSuffix common_suffix xtn + sti = stripSuffix common_suffix xti + return (nl3, il3, common_suffix, stn, sti) diff --git a/Ganeti/HTools/Node.hs b/Ganeti/HTools/Node.hs index 37d3d9249..c5856fbe7 100644 --- a/Ganeti/HTools/Node.hs +++ b/Ganeti/HTools/Node.hs @@ -38,8 +38,6 @@ import qualified Ganeti.HTools.Container as Container import qualified Ganeti.HTools.Instance as Instance import qualified Ganeti.HTools.PeerMap as PeerMap -import Ganeti.HTools.Utils - data Node = Node { t_mem :: Double -- ^ total memory (MiB) , n_mem :: Int -- ^ node memory (MiB) , f_mem :: Int -- ^ free memory (MiB) diff --git a/Ganeti/HTools/Rapi.hs b/Ganeti/HTools/Rapi.hs index 5cfc42b4d..58540e1da 100644 --- a/Ganeti/HTools/Rapi.hs +++ b/Ganeti/HTools/Rapi.hs @@ -17,6 +17,7 @@ import Text.Printf (printf) import Ganeti.HTools.Utils import Ganeti.HTools.Loader +import Ganeti.HTools.Types import qualified Ganeti.HTools.Node as Node import qualified Ganeti.HTools.Instance as Instance @@ -58,7 +59,7 @@ parseInstance ktn a = do disk <- fromObj "disk_usage" a mem <- fromObj "beparams" a >>= fromObj "memory" pnode <- fromObj "pnode" a >>= lookupNode ktn name - snodes <- getListElement "snodes" a + snodes <- fromObj "snodes" a snode <- (if null snodes then return Node.noSecondary else readEitherString (head snodes) >>= lookupNode ktn name) running <- fromObj "status" a diff --git a/Ganeti/HTools/Text.hs b/Ganeti/HTools/Text.hs index f643e5f5b..a148c2b02 100644 --- a/Ganeti/HTools/Text.hs +++ b/Ganeti/HTools/Text.hs @@ -12,6 +12,7 @@ import Control.Monad import Ganeti.HTools.Utils import Ganeti.HTools.Loader +import Ganeti.HTools.Types import qualified Ganeti.HTools.Node as Node import qualified Ganeti.HTools.Instance as Instance diff --git a/Ganeti/HTools/Types.hs b/Ganeti/HTools/Types.hs new file mode 100644 index 000000000..0a248028e --- /dev/null +++ b/Ganeti/HTools/Types.hs @@ -0,0 +1,41 @@ +{-| Some common types. + +-} + +module Ganeti.HTools.Types + where + +import qualified Ganeti.HTools.Container as Container +import qualified Ganeti.HTools.Instance as Instance +import qualified Ganeti.HTools.Node as Node + +type NodeList = Container.Container Node.Node +type InstanceList = Container.Container Instance.Instance + +-- | The type used to hold idx-to-name mappings +type NameList = [(Int, String)] + +-- | The type used to hold name-to-idx mappings +type NameAssoc = [(String, Int)] + +type IdxNode = [(Int, Node.Node)] +type IdxInstance = [(Int, Instance.Instance)] + +{- + +This is similar to the JSON library Result type - *very* similar, but +we want to use it in multiple places, so we abstract it into a +mini-library here + +-} + +data Result a + = Bad String + | Ok a + deriving (Show) + +instance Monad Result where + (>>=) (Bad x) _ = Bad x + (>>=) (Ok x) fn = fn x + return = Ok + fail = Bad diff --git a/Ganeti/HTools/Utils.hs b/Ganeti/HTools/Utils.hs index d26e7c7d9..89cf3cbb0 100644 --- a/Ganeti/HTools/Utils.hs +++ b/Ganeti/HTools/Utils.hs @@ -4,26 +4,17 @@ module Ganeti.HTools.Utils ( debug , sepSplit - , swapPairs , varianceCoeff , readData , commaJoin , readEitherString , loadJSArray , fromObj - , getStringElement - , getIntElement - , getBoolElement - , getListElement - , getObjectElement , asJSObject , asObjectList - , Result(Ok, Bad) , fromJResult - , (|+) ) where -import Data.Either import Data.List import Control.Monad import System @@ -31,6 +22,8 @@ import System.IO import qualified Text.JSON as J import Text.Printf (printf) +import Ganeti.HTools.Types + import Debug.Trace -- | To be used only for debugging, breaks referential integrity. @@ -38,25 +31,6 @@ debug :: Show a => a -> a debug x = trace (show x) x -{- - -This is similar to the JSON library Result type - *very* similar, but -we want to use it in multiple places, so we abstract it into a -mini-library here - --} - -data Result a - = Bad String - | Ok a - deriving (Show) - -instance Monad Result where - (>>=) (Bad x) _ = Bad x - (>>=) (Ok x) fn = fn x - return = Ok - fail = Bad - fromJResult :: Monad m => J.Result a -> m a fromJResult (J.Error x) = fail x fromJResult (J.Ok x) = return x @@ -79,10 +53,6 @@ sepSplit sep s commaSplit :: String -> [String] commaSplit = sepSplit ',' --- | Swap a list of @(a, b)@ into @(b, a)@ -swapPairs :: [(a, b)] -> [(b, a)] -swapPairs = map (\ (a, b) -> (b, a)) - -- Simple and slow statistical functions, please replace with better versions -- | Mean value of a list. @@ -126,29 +96,9 @@ fromObj k o = Nothing -> fail $ printf "key '%s' not found in %s" k (show o) Just val -> fromJResult $ J.readJSON val -getStringElement :: (Monad m) => String -> J.JSObject J.JSValue -> m String -getStringElement = fromObj - -getIntElement :: (Monad m) => String -> J.JSObject J.JSValue -> m Int -getIntElement = fromObj - -getBoolElement :: (Monad m) => String -> J.JSObject J.JSValue -> m Bool -getBoolElement = fromObj - -getListElement :: (Monad m) => String -> J.JSObject J.JSValue -> m [J.JSValue] -getListElement = fromObj - -getObjectElement :: (Monad m) => String -> J.JSObject J.JSValue - -> m (J.JSObject J.JSValue) -getObjectElement = fromObj - asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue) asJSObject (J.JSObject a) = return a asJSObject _ = fail "not an object" asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue] asObjectList = sequence . map asJSObject - --- | Function to concat two strings with a separator under a monad -(|+) :: (Monad m) => m String -> m String -> m String -(|+) = liftM2 (\x y -> x ++ "|" ++ y) diff --git a/hail.hs b/hail.hs index 69ada441b..bcaeb5e32 100644 --- a/hail.hs +++ b/hail.hs @@ -21,6 +21,7 @@ import qualified Ganeti.HTools.Node as Node import qualified Ganeti.HTools.CLI as CLI import Ganeti.HTools.IAlloc import Ganeti.HTools.Utils +import Ganeti.HTools.Types -- | Command line options structure. data Options = Options diff --git a/hbal.hs b/hbal.hs index 459574ea8..4e09e080f 100644 --- a/hbal.hs +++ b/hbal.hs @@ -21,8 +21,10 @@ import qualified Ganeti.HTools.Node as Node import qualified Ganeti.HTools.CLI as CLI import qualified Ganeti.HTools.Rapi as Rapi import qualified Ganeti.HTools.Text as Text +import qualified Ganeti.HTools.Loader as Loader import Ganeti.HTools.Utils +import Ganeti.HTools.Types -- | Command line options structure. data Options = Options @@ -186,7 +188,7 @@ main = do "" -> Text.loadData nodef instf host -> Rapi.loadData host - let ldresult = input_data >> Cluster.loadData + let ldresult = input_data >>= Loader.mergeData (loaded_nl, il, csf, ktn, kti) <- (case ldresult of diff --git a/hn1.hs b/hn1.hs index 2cb10c60b..3643e8dd1 100644 --- a/hn1.hs +++ b/hn1.hs @@ -20,7 +20,8 @@ import qualified Ganeti.HTools.Cluster as Cluster import qualified Ganeti.HTools.CLI as CLI import qualified Ganeti.HTools.Rapi as Rapi import qualified Ganeti.HTools.Text as Text -import Ganeti.HTools.Utils +import qualified Ganeti.HTools.Loader as Loader +import Ganeti.HTools.Types -- | Command line options structure. data Options = Options @@ -61,7 +62,7 @@ defaultOptions = Options we find a valid solution or we exceed the maximum depth. -} -iterateDepth :: Cluster.NodeList +iterateDepth :: NodeList -> [Instance.Instance] -> Int -> Int @@ -150,7 +151,7 @@ main = do case optMaster opts of "" -> Text.loadData nodef instf host -> Rapi.loadData host - let ldresult = input_data >>= Cluster.loadData + let ldresult = input_data >>= Loader.mergeData (loaded_nl, il, csf, ktn, kti) <- (case ldresult of diff --git a/hscan.hs b/hscan.hs index 45c1b10a3..ec8202309 100644 --- a/hscan.hs +++ b/hscan.hs @@ -22,7 +22,8 @@ import qualified Ganeti.HTools.Node as Node import qualified Ganeti.HTools.Instance as Instance import qualified Ganeti.HTools.CLI as CLI import qualified Ganeti.HTools.Rapi as Rapi -import Ganeti.HTools.Utils +import qualified Ganeti.HTools.Loader as Loader +import Ganeti.HTools.Types -- | Command line options structure. data Options = Options @@ -159,7 +160,7 @@ main = do printf "%-*s " nlen name hFlush stdout input_data <- Rapi.loadData name - let ldresult = input_data >>= Cluster.loadData + let ldresult = input_data >>= Loader.mergeData (case ldresult of Bad err -> printf "\nError: failed to load data. \ \Details:\n%s\n" err -- GitLab