Commit e4c5beaf authored by Iustin Pop's avatar Iustin Pop
Browse files

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
parent 040afc35
......@@ -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 =
......
......@@ -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 =
......
......@@ -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)
......@@ -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)
......
......@@ -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
......
......@@ -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
......
{-| 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
......@@ -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)
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......