Commit e4f08c46 authored by Iustin Pop's avatar Iustin Pop

Initial import

This is the initial import of release 0.0.3.
parents
This diff is collapsed.
HSRCS := $(wildcard src/*.hs)
HDDIR = apidoc
# Haskell rules
all:
$(MAKE) -C src
README.html: README
rst2html $< $@
doc: README.html
rm -rf $(HDDIR)
mkdir -p $(HDDIR)/src
cp hscolour.css $(HDDIR)/src
for file in $(HSRCS); do \
HsColour -css -anchor \
$$file > $(HDDIR)/src/`basename $$file .hs`.html ; \
done
ln -sf hn1.html $(HDDIR)/src/Main.html
haddock --odir $(HDDIR) --html --ignore-all-exports \
-t hn1 -p haddock-prologue \
--source-module="src/%{MODULE/.//}.html" \
--source-entity="src/%{MODULE/.//}.html#%{NAME}" \
$(HSRCS)
clean:
rm -f *.o *.cmi *.cmo *.cmx *.old hn1 zn1 *.prof *.ps *.stat *.aux \
gmon.out *.hi README.html TAGS
.PHONY : all doc clean hn1
This diff is collapsed.
This is the internal documentation for hn1, an experimental N+1
cluster solver.
Start with the "Main" module, the follow with "Cluster" and then the
rest.
.keyglyph, .layout {color: red;}
.keyword {color: blue;}
.comment, .comment a {color: green;}
.str, .chr {color: teal;}
.keyword,.conid, .varid, .conop, .varop, .num, .cpp, .sel, .definition {}
This diff is collapsed.
{-| Module abstracting the node and instance container implementation.
This is currently implemented on top of an 'IntMap', which seems to
give the best performance for our workload.
-}
module Container
(
-- * Types
Container
-- * Creation
, empty
, fromAssocList
-- * Query
, size
, find
-- * Update
, add
, addTwo
, remove
-- * Conversion
, elems
) where
import qualified Data.IntMap as IntMap
type Key = IntMap.Key
type Container = IntMap.IntMap
-- | Create an empty container.
empty :: Container a
empty = IntMap.empty
-- | Returns the number of elements in the map.
size :: Container a -> Int
size = IntMap.size
-- | Locate a key in the map (must exist).
find :: Key -> Container a -> a
find k c = c IntMap.! k
-- | Locate a keyin the map returning a default value if not existing.
findWithDefault :: a -> Key -> Container a -> a
findWithDefault = IntMap.findWithDefault
-- | Add or update one element to the map.
add :: Key -> a -> Container a -> Container a
add k v c = IntMap.insert k v c
-- | Remove an element from the map.
remove :: Key -> Container a -> Container a
remove = IntMap.delete
-- | Return the list of values in the map.
elems :: Container a -> [a]
elems = IntMap.elems
-- | Create a map from an association list.
fromAssocList :: [(Key, a)] -> Container a
fromAssocList = IntMap.fromList
-- | Create a map from an association list with a combining function.
fromListWith :: (a -> a -> a) -> [(Key, a)] -> Container a
fromListWith = IntMap.fromListWith
-- | Fold over the values of the map.
fold :: (a -> b -> b) -> b -> Container a -> b
fold = IntMap.fold
-- | Add or update two elements of the map.
addTwo :: Key -> a -> Key -> a -> Container a -> Container a
addTwo k1 v1 k2 v2 c = add k1 v1 $ add k2 v2 c
{-| Module describing an instance.
The instance data type holds very few fields, the algorithm
intelligence is in the "Node" and "Cluster" modules.
-}
module Instance where
data Instance = Instance { mem :: Int -- ^ memory of the instance
, disk :: Int -- ^ disk size of instance
, pnode :: Int -- ^ original primary node
, snode :: Int -- ^ original secondary node
, idx :: Int -- ^ internal index for book-keeping
} deriving (Show)
create :: String -> String -> Instance
create mem_init disk_init = Instance {
mem = read mem_init,
disk = read disk_init,
pnode = -1,
snode = -1,
idx = -1
}
-- | Changes the primary node of the instance.
setPri :: Instance -- ^ the original instance
-> Int -- ^ the new primary node
-> Instance -- ^ the modified instance
setPri t p = t { pnode = p }
-- | Changes the secondary node of the instance.
setSec :: Instance -- ^ the original instance
-> Int -- ^ the new secondary node
-> Instance -- ^ the modified instance
setSec t s = t { snode = s }
-- | Changes both nodes of the instance.
setBoth :: Instance -- ^ the original instance
-> Int -- ^ new primary node index
-> Int -- ^ new secondary node index
-> Instance -- ^ the modified instance
setBoth t p s = t { pnode = p, snode = s }
-- | Changes the index.
-- This is used only during the building of the data structures.
setIdx :: Instance -- ^ the original instance
-> Int -- ^ new index
-> Instance -- ^ the modified instance
setIdx t i = t { idx = i }
all: hn1 hbal
hn1:
ghc --make -O2 -W hn1
hbal:
ghc --make -O2 -W hbal
clean:
rm -f *.o *.cmi *.cmo *.cmx *.old hn1 zn1 *.prof *.ps *.stat *.aux \
gmon.out *.hi README.html TAGS
.PHONY : all clean hn1 hbal
{-| Module describing a node.
All updates are functional (copy-based) and return a new node with
updated value.
-}
module Node
(
Node(failN1, idx, f_mem, f_disk, slist, plist)
-- * Constructor
, create
-- ** Finalization after data loading
, buildPeers
, setIdx
-- * Instance (re)location
, removePri
, removeSec
, addPri
, addSec
-- * Statistics
, normUsed
-- * Formatting
, list
) where
import Data.List
import Text.Printf (printf)
import qualified Container
import qualified Instance
import qualified PeerMap
import Utils
data Node = Node { t_mem :: Int -- ^ total memory (Mib)
, f_mem :: Int -- ^ free memory (MiB)
, t_disk :: Int -- ^ total disk space (MiB)
, f_disk :: Int -- ^ free disk space (MiB)
, plist :: [Int] -- ^ list of primary instance indices
, slist :: [Int] -- ^ list of secondary instance indices
, idx :: Int -- ^ internal index for book-keeping
, peers:: PeerMap.PeerMap -- ^ primary node to instance
-- mapping
, failN1:: Bool -- ^ whether the node has failed n1
, maxRes :: Int -- ^ maximum memory needed for
-- failover by primaries of this node
} deriving (Show)
{- | Create a new node.
The index and the peers maps are empty, and will be need to be update
later via the 'setIdx' and 'buildPeers' functions.
-}
create :: String -> String -> String -> String -> [Int] -> [Int] -> Node
create mem_t_init mem_f_init disk_t_init disk_f_init
plist_init slist_init = Node
{
t_mem = read mem_t_init,
f_mem = read mem_f_init,
t_disk = read disk_t_init,
f_disk = read disk_f_init,
plist = plist_init,
slist = slist_init,
failN1 = True,
idx = -1,
peers = PeerMap.empty,
maxRes = 0
}
-- | Changes the index.
-- This is used only during the building of the data structures.
setIdx :: Node -> Int -> Node
setIdx t i = t {idx = i}
-- | Given the rmem, free memory and disk, computes the failn1 status.
computeFailN1 :: Int -> Int -> Int -> Bool
computeFailN1 new_rmem new_mem new_disk =
new_mem <= new_rmem || new_disk <= 0
-- | Computes the maximum reserved memory for peers from a peer map.
computeMaxRes :: PeerMap.PeerMap -> PeerMap.Elem
computeMaxRes new_peers = PeerMap.maxElem new_peers
-- | Builds the peer map for a given node.
buildPeers :: Node -> Container.Container Instance.Instance -> Int -> Node
buildPeers t il num_nodes =
let mdata = map
(\i_idx -> let inst = Container.find i_idx il
in (Instance.pnode inst, Instance.mem inst))
(slist t)
pmap = PeerMap.accumArray (+) 0 (0, num_nodes - 1) mdata
new_rmem = computeMaxRes pmap
new_failN1 = computeFailN1 new_rmem (f_mem t) (f_disk t)
in t {peers=pmap, failN1 = new_failN1, maxRes = new_rmem}
-- | Removes a primary instance.
removePri :: Node -> Instance.Instance -> Node
removePri t inst =
let iname = Instance.idx inst
new_plist = delete iname (plist t)
new_mem = f_mem t + Instance.mem inst
new_disk = f_disk t + Instance.disk inst
new_failn1 = computeFailN1 (maxRes t) new_mem new_disk
in t {plist = new_plist, f_mem = new_mem, f_disk = new_disk,
failN1 = new_failn1}
-- | Removes a secondary instance.
removeSec :: Node -> Instance.Instance -> Node
removeSec t inst =
let iname = Instance.idx inst
pnode = Instance.pnode inst
new_slist = delete iname (slist t)
new_disk = f_disk t + Instance.disk inst
old_peers = peers t
old_peem = PeerMap.find pnode old_peers
new_peem = old_peem - (Instance.mem inst)
new_peers = PeerMap.add pnode new_peem old_peers
old_rmem = maxRes t
new_rmem = if old_peem < old_rmem then
old_rmem
else
computeMaxRes new_peers
new_failn1 = computeFailN1 new_rmem (f_mem t) new_disk
in t {slist = new_slist, f_disk = new_disk, peers = new_peers,
failN1 = new_failn1, maxRes = new_rmem}
-- | Adds a primary instance.
addPri :: Node -> Instance.Instance -> Maybe Node
addPri t inst =
let iname = Instance.idx inst
new_mem = f_mem t - Instance.mem inst
new_disk = f_disk t - Instance.disk inst
new_failn1 = computeFailN1 (maxRes t) new_mem new_disk in
if new_failn1 then
Nothing
else
let new_plist = iname:(plist t) in
Just t {plist = new_plist, f_mem = new_mem, f_disk = new_disk,
failN1 = new_failn1}
-- | Adds a secondary instance.
addSec :: Node -> Instance.Instance -> Int -> Maybe Node
addSec t inst pdx =
let iname = Instance.idx inst
old_peers = peers t
new_disk = f_disk t - Instance.disk inst
new_peem = PeerMap.find pdx old_peers + Instance.mem inst
new_peers = PeerMap.add pdx new_peem old_peers
new_rmem = max (maxRes t) new_peem
new_failn1 = computeFailN1 new_rmem (f_mem t) new_disk in
if new_failn1 then
Nothing
else
let new_slist = iname:(slist t) in
Just t {slist = new_slist, f_disk = new_disk,
peers = new_peers, failN1 = new_failn1,
maxRes = new_rmem}
-- | Simple converter to string.
str :: Node -> String
str t =
printf ("Node %d (mem=%5d MiB, disk=%5.2f GiB)\n Primaries:" ++
" %s\nSecondaries: %s")
(idx t) (f_mem t) ((f_disk t) `div` 1024)
(commaJoin (map show (plist t)))
(commaJoin (map show (slist t)))
-- | String converter for the node list functionality.
list :: String -> Node -> String
list n t =
let pl = plist t
sl = slist t
(mp, dp) = normUsed t
in
printf " %s(%d)\t%5d\t%5d\t%3d\t%3d\t%s\t%s\t%.5f\t%.5f"
n (idx t) (f_mem t) ((f_disk t) `div` 1024)
(length pl) (length sl)
(commaJoin (map show pl))
(commaJoin (map show sl))
mp dp
-- | Normalize the usage status
-- This converts the used memory and disk values into a normalized integer
-- value, currently expresed as per mille of totals
normUsed :: Node -> (Double, Double)
normUsed n =
let mp = (fromIntegral $ f_mem n) / (fromIntegral $ t_mem n)
dp = (fromIntegral $ f_disk n) / (fromIntegral $ t_disk n)
in (mp, dp)
{-|
Module abstracting the peer map implementation.
This is abstracted separately since the speed of peermap updates can
be a significant part of the total runtime, and as such changing the
implementation should be easy in case it's needed.
-}
module PeerMap (
PeerMap,
Key,
Elem,
empty,
create,
accumArray,
PeerMap.find,
add,
remove,
maxElem
)
where
import Data.Maybe (fromMaybe)
import Data.List
import Data.Function
import Data.Ord
type Key = Int
type Elem = Int
type PeerMap = [(Key, Elem)]
empty :: PeerMap
empty = []
create :: Key -> PeerMap
create _ = []
-- | Our reverse-compare function
pmCompare :: (Key, Elem) -> (Key, Elem) -> Ordering
pmCompare a b = (compare `on` snd) b a
addWith :: (Elem -> Elem -> Elem) -> Key -> Elem -> PeerMap -> PeerMap
addWith fn k v lst =
let r = lookup k lst
in
case r of
Nothing -> insertBy pmCompare (k, v) lst
Just o -> insertBy pmCompare (k, fn o v) (remove k lst)
accumArray :: (Elem -> Elem -> Elem) -> Elem -> (Key, Key) ->
[(Key, Elem)] -> PeerMap
accumArray fn _ _ lst =
case lst of
[] -> empty
(k, v):xs -> addWith fn k v $ accumArray fn undefined undefined xs
find :: Key -> PeerMap -> Elem
find k c = fromMaybe 0 $ lookup k c
add :: Key -> Elem -> PeerMap -> PeerMap
add k v c = addWith (\_ n -> n) k v c
remove :: Key -> PeerMap -> PeerMap
remove k c = case c of
[] -> []
(x@(x', _)):xs -> if k == x' then xs
else x:(remove k xs)
to_list :: PeerMap -> [Elem]
to_list c = snd $ unzip c
maxElem :: PeerMap -> Elem
maxElem c = case c of
[] -> 0
(_, v):_ -> v
{-| Utility functions -}
module Utils where
import Data.List
import Debug.Trace
-- | To be used only for debugging, breaks referential integrity.
debug :: Show a => a -> a
debug x = trace (show x) x
-- | Comma-join a string list.
commaJoin :: [String] -> String
commaJoin = intercalate ","
-- | Split a string on a separator and return an array.
sepSplit :: Char -> String -> [String]
sepSplit sep s
| x == "" && xs == [] = []
| xs == [] = [x]
| ys == [] = x:"":[]
| otherwise = x:(sepSplit sep ys)
where (x, xs) = break (== sep) s
ys = drop 1 xs
-- | Partial application of sepSplit to @'.'@
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.
meanValue :: Floating a => [a] -> a
meanValue lst = (sum lst) / (fromIntegral $ length lst)
-- | Standard deviation.
stdDev :: Floating a => [a] -> a
stdDev lst =
let mv = meanValue lst
square = (^ (2::Int)) -- silences "defaulting the constraint..."
av = sum $ map square $ map (\e -> e - mv) lst
bv = sqrt (av / (fromIntegral $ length lst))
in bv
-- | Coefficient of variation.
varianceCoeff :: Floating a => [a] -> a
varianceCoeff lst = (stdDev lst) / (fromIntegral $ length lst)
{-| Solver for N+1 cluster errors
-}
module Main (main) where
import Data.List
import Data.Function
import Monad
import System
import System.IO
import System.Console.GetOpt
import qualified System
import Text.Printf (printf)
import qualified Container
import qualified Cluster
-- | Command line options structure.
data Options = Options
{ optShowNodes :: Bool
, optShowCmds :: Bool
, optNodef :: FilePath
, optInstf :: FilePath
, optMaxRounds :: Int
} deriving Show
-- | Default values for the command line options.
defaultOptions :: Options
defaultOptions = Options
{ optShowNodes = False
, optShowCmds = False
, optNodef = "nodes"
, optInstf = "instances"
, optMaxRounds = -1
}
{- | Start computing the solution at the given depth and recurse until
we find a valid solution or we exceed the maximum depth.
-}
iterateDepth :: Cluster.Table
-> Int -- ^ Current round
-> Int -- ^ Max rounds
-> IO Cluster.Table
iterateDepth ini_tbl cur_round max_rounds =
let Cluster.Table _ ini_il ini_cv ini_plc = ini_tbl
all_inst = Container.elems ini_il
fin_tbl = Cluster.checkMove ini_tbl all_inst
(Cluster.Table _ _ fin_cv fin_plc) = fin_tbl
ini_plc_len = length ini_plc
fin_plc_len = length fin_plc
allowed_next = (max_rounds < 0 || cur_round < max_rounds)
in
do
printf " - round %d: " cur_round
hFlush stdout
let msg =
if fin_cv < ini_cv then
if not allowed_next then
printf "%.8f, %d moves (stopping due to round limit)\n"
fin_cv
(fin_plc_len - ini_plc_len)
else
printf "%.8f, %d moves\n" fin_cv
(fin_plc_len - ini_plc_len)
else
"no improvement, stopping\n"
putStr msg
hFlush stdout
(if fin_cv < ini_cv then -- this round made success, try deeper
if allowed_next
then iterateDepth fin_tbl (cur_round + 1) max_rounds
-- don't go deeper, but return the better solution
else return fin_tbl
else
return ini_tbl)
-- | Options list and functions
options :: [OptDescr (Options -> Options)]
options =
[ Option ['p'] ["print-nodes"]
(NoArg (\ opts -> opts { optShowNodes = True }))
"print the final node list"
, Option ['C'] ["print-commands"]
(NoArg (\ opts -> opts { optShowCmds = True }))
"print the ganeti command list for reaching the solution"
, Option ['n'] ["nodes"]
(ReqArg (\ f opts -> opts { optNodef = f }) "FILE")
"the node list FILE"
, Option ['i'] ["instances"]
(ReqArg (\ f opts -> opts { optInstf = f }) "FILE")
"the instance list FILE"
, Option ['r'] ["max-rounds"]
(ReqArg (\ i opts -> opts { optMaxRounds = (read i)::Int }) "N")
"do not run for more than R rounds(useful for very unbalanced clusters)"
]
-- | Command line parser, using the 'options' structure.
parseOpts :: [String] -> IO (Options, [String])
parseOpts argv =
case getOpt Permute options argv of
(o,n,[] ) ->
return (foldl (flip id) defaultOptions o, n)
(_,_,errs) ->
ioError (userError (concat errs ++ usageInfo header options))
where header = "Usage: hbal [OPTION...]"
-- | Main function.
main :: IO ()
main = do
cmd_args <- System.getArgs
(opts, _) <- parseOpts cmd_args
(nl, il, ktn, kti) <- liftM2 Cluster.loadData
(readFile $ optNodef opts)
(readFile $ optInstf opts)
printf "Loaded %d nodes, %d instances\n"
(Container.size nl)
(Container.size il)
let (bad_nodes, bad_instances) = Cluster.computeBadItems nl il
printf "Initial check done: %d bad nodes, %d bad instances.\n"
(length bad_nodes) (length bad_instances)
when (length bad_nodes > 0) $ do
putStrLn "Cluster is not N+1 happy, please fix N+1 first. Exiting."
exitWith $ ExitFailure 1
when (optShowNodes opts) $
do
putStrLn "Initial cluster status:"
putStrLn $ Cluster.printNodes ktn nl
let ini_cv = Cluster.compCV nl
ini_tbl = Cluster.Table nl il ini_cv []
printf "Initial coefficients: overall %.8f, %s\n"
ini_cv (Cluster.printStats nl)
putStrLn "Trying to minimize the CV..."
fin_tbl <- iterateDepth ini_tbl 1 (optMaxRounds opts)
let (Cluster.Table fin_nl _ fin_cv fin_plc) = fin_tbl
ord_plc = reverse fin_plc
printf "Final coefficients: overall %.8f, %s\n"
fin_cv
(Cluster.printStats fin_nl)
printf "Solution length=%d\n" (length ord_plc)
let (sol_strs, cmd_strs) = Cluster.printSolution il ktn kti ord_plc
putStr $ unlines $ sol_strs
when (optShowCmds opts) $
do
putStrLn ""
putStrLn "Commands to run to reach the above solution:"
putStr $ unlines $ map (" echo gnt-instance " ++) $ concat cmd_strs
when (optShowNodes opts) $
do
let (orig_mem, orig_disk) = Cluster.totalResources nl
(final_mem, final_disk) = Cluster.totalResources fin_nl
putStrLn ""
putStrLn "Final cluster status:"
putStrLn $ Cluster.printNodes ktn fin_nl
printf "Original: mem=%d disk=%d\n" orig_mem orig_disk
printf "Final: mem=%d disk=%d\n" final_mem final_disk
{-| Solver for N+1 cluster errors
-}
module Main (main) where
import Data.List
import Data.Function
import Monad
import System
import System.IO
import System.Console.GetOpt
import qualified System