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
import Text.Printf (printf)
import qualified Container
import qualified Instance
import qualified Cluster
-- | Command line options structure.
data Options = Options
{ optShowNodes :: Bool
, optShowCmds :: Bool
, optNodef :: FilePath
, optInstf :: FilePath
, optMinDepth :: Int
, optMaxRemovals :: Int
, optMinDelta :: Int
, optMaxDelta :: Int
} deriving Show
-- | Default values for the command line options.
defaultOptions :: Options
defaultOptions = Options
{ optShowNodes = False
, optShowCmds = False
, optNodef = "nodes"
, optInstf = "instances"
, optMinDepth = 1
, optMaxRemovals = -1
, optMinDelta = 0
, optMaxDelta = -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.NodeList
-> [Instance.Instance]
-> Int
-> Int
-> Int
-> Int
-> IO (Maybe Cluster.Solution)
iterateDepth nl bad_instances depth max_removals min_delta max_delta =
let
max_depth = length bad_instances
sol = Cluster.computeSolution nl bad_instances depth
max_removals min_delta max_delta
in
do
printf "%d " depth
hFlush stdout
case sol `seq` sol of