Start implementing the hail functionality

This patch implements a very stupid (and broken) version of hail
‘allocate’.

Ganeti/HTools/IAlloc.hs

@@ -6,6 +6,8 @@ module Ganeti.HTools.IAlloc
     (
       parseData
     , formatResponse
+    , RqType(..)
+    , Request(..)
     ) where
 
 import Data.Either ()
@@ -22,8 +24,8 @@ import Ganeti.HTools.Utils
 import Ganeti.HTools.Types
 
 data RqType
-    = Allocate String Instance.Instance
-    | Relocate Int
+    = Allocate Instance.Instance Int
+    | Relocate Int Int [Int]
     deriving (Show)
 
 data Request = Request RqType NodeList InstanceList String
@@ -88,20 +90,24 @@ parseData body = do
   let idata = fromJSObject ilist
   iobj <- (mapM (\(x,y) -> asJSObject y >>= parseInstance ktn x)) idata
   let (kti, il) = assignIndices iobj
+  (map_n, map_i, csf) <- mergeData (nl, il)
+  req_nodes <- fromObj "required_nodes" request
   optype <- fromObj "type" request
   rqtype <-
       case optype of
         "allocate" ->
             do
               inew <- parseBaseInstance rname request
-              let (iname, io) = inew
-              return $ Allocate iname io
+              let io = snd inew
+              return $ Allocate io req_nodes
         "relocate" ->
             do
               ridx <- lookupNode kti rname rname
-              return $ Relocate ridx
+              ex_nodes <- fromObj "relocate_from" request
+              let ex_nodes' = map (stripSuffix $ length csf) ex_nodes
+              ex_idex <- mapM (findByName map_n) ex_nodes'
+              return $ Relocate ridx req_nodes ex_idex
         other -> fail $ ("Invalid request type '" ++ other ++ "'")
-  (map_n, map_i, csf) <- mergeData (nl, il)
   return $ Request rqtype map_n map_i csf
 
 formatResponse :: Bool -> String -> [String] -> String

Ganeti/HTools/Loader.hs

@@ -9,6 +9,7 @@ module Ganeti.HTools.Loader
     , checkData
     , assignIndices
     , lookupNode
+    , stripSuffix
     ) where
 
 import Data.List

Ganeti/HTools/Types.hs

@@ -68,3 +68,17 @@ cNameOf c k = name $ Container.find k c
 -- | Compute the maximum name length in an Element Container
 cMaxNamelen :: (Element a) => Container.Container a -> Int
 cMaxNamelen = maximum . map (length . name) . Container.elems
+
+-- | Find an element by name in a Container; this is a very slow function
+findByName :: (Element a, Monad m) =>
+              Container.Container a -> String -> m Container.Key
+findByName c n =
+    let all_elems = Container.elems c
+        result = filter ((== n) . name) all_elems
+        nems = length result
+    in
+      if nems /= 1 then
+          fail $ "Wrong number of elems (" ++ (show nems) ++
+                   ") found with name " ++ n
+      else
+          return $ idx $ head result

hail.hs

@@ -18,6 +18,7 @@ import Text.Printf (printf)
 import qualified Ganeti.HTools.Container as Container
 import qualified Ganeti.HTools.Cluster as Cluster
 import qualified Ganeti.HTools.Node as Node
+import qualified Ganeti.HTools.Instance as Instance
 import qualified Ganeti.HTools.CLI as CLI
 import Ganeti.HTools.IAlloc
 import Ganeti.HTools.Utils
@@ -112,11 +113,25 @@ options =
       "show help"
     ]
 
--- | Formats the solution for the oneline display
-formatOneline :: Double -> Int -> Double -> String
-formatOneline ini_cv plc_len fin_cv =
-    printf "%.8f %d %.8f %8.3f" ini_cv plc_len fin_cv
-               (if fin_cv == 0 then 1 else (ini_cv / fin_cv))
+-- | Try to allocate an instance on the cluster
+tryAlloc :: NodeList
+         -> InstanceList
+         -> Instance.Instance
+         -> Int
+         -> Result [Node.Node]
+tryAlloc nl il xi _ = Bad "alloc not implemented"
+
+-- | Try to allocate an instance on the cluster
+tryReloc :: NodeList
+         -> InstanceList
+         -> Int
+         -> Int
+         -> [Int]
+         -> Result [Node.Node]
+tryReloc nl il xid reqn ex_idx =
+    let all_nodes = Container.elems nl
+        valid_nodes = filter (not . flip elem ex_idx . idx) all_nodes
+    in Ok (take reqn valid_nodes)
 
 -- | Main function.
 main :: IO ()
@@ -138,127 +153,13 @@ main = do
                  exitWith $ ExitFailure 1
                Ok rq -> return rq
 
-  putStrLn $ show request
-  exitWith ExitSuccess
-{-
-  (loaded_nl, il, csf, ktn, kti) <- liftM2 Cluster.loadData node_data inst_data
-  let (fix_msgs, fixed_nl) = Cluster.checkData loaded_nl il ktn kti
-
-  unless (null fix_msgs || verbose == 0) $ do
-         putStrLn "Warning: cluster has inconsistent data:"
-         putStrLn . unlines . map (\s -> printf "  - %s" s) $ fix_msgs
-
-  let offline_names = optOffline opts
-      all_names = snd . unzip $ ktn
-      offline_wrong = filter (\n -> not $ elem n all_names) offline_names
-      offline_indices = fst . unzip .
-                        filter (\(_, n) -> elem n offline_names) $ ktn
-
-  when (length offline_wrong > 0) $ do
-         printf "Wrong node name(s) set as offline: %s\n"
-                (commaJoin offline_wrong)
-         exitWith $ ExitFailure 1
-
-  let nl = Container.map (\n -> if elem (Node.idx n) offline_indices
-                                then Node.setOffline n True
-                                else n) fixed_nl
-
-  when (Container.size il == 0) $ do
-         (if oneline then
-              putStrLn $ formatOneline 0 0 0
-          else
-              printf "Cluster is empty, exiting.\n")
-         exitWith ExitSuccess
-
-
-  unless oneline $ printf "Loaded %d nodes, %d instances\n"
-             (Container.size nl)
-             (Container.size il)
-
-  when (length csf > 0 && not oneline && verbose > 1) $ do
-         printf "Note: Stripping common suffix of '%s' from names\n" csf
-
-  let (bad_nodes, bad_instances) = Cluster.computeBadItems nl il
-  unless (oneline || verbose == 0) $ 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, continuing but no guarantee \
-                  \that the cluster will end N+1 happy."
-
-  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 []
-      min_cv = optMinScore opts
-
-  when (ini_cv < min_cv) $ do
-         (if oneline then
-              putStrLn $ formatOneline ini_cv 0 ini_cv
-          else printf "Cluster is already well balanced (initial score %.6g,\n\
-                      \minimum score %.6g).\nNothing to do, exiting\n"
-                      ini_cv min_cv)
-         exitWith ExitSuccess
-
-  unless oneline (if verbose > 2 then
-                      printf "Initial coefficients: overall %.8f, %s\n"
-                      ini_cv (Cluster.printStats nl)
-                  else
-                      printf "Initial score: %.8f\n" ini_cv)
-
-  unless oneline $ putStrLn "Trying to minimize the CV..."
-  let mlen_fn = maximum . (map length) . snd . unzip
-      imlen = mlen_fn kti
-      nmlen = mlen_fn ktn
-
-  (fin_tbl, cmd_strs) <- iterateDepth ini_tbl (optMaxLength opts)
-                         ktn kti nmlen imlen [] oneline min_cv
-  let (Cluster.Table fin_nl _ fin_cv fin_plc) = fin_tbl
-      ord_plc = reverse fin_plc
-      sol_msg = if null fin_plc
-                then printf "No solution found\n"
-                else (if verbose > 2
-                      then printf "Final coefficients:   overall %.8f, %s\n"
-                           fin_cv (Cluster.printStats fin_nl)
-                      else printf "Cluster score improved from %.8f to %.8f\n"
-                           ini_cv fin_cv
-                     )
-
-  unless oneline $ putStr sol_msg
-
-  unless (oneline || verbose == 0) $
-         printf "Solution length=%d\n" (length ord_plc)
-
-  let cmd_data = Cluster.formatCmds . reverse $ cmd_strs
-
-  when (isJust $ optShowCmds opts) $
-       do
-         let out_path = fromJust $ optShowCmds opts
-         putStrLn ""
-         (if out_path == "-" then
-              printf "Commands to run to reach the above solution:\n%s"
-                     (unlines . map ("  " ++) .
-                      filter (/= "check") .
-                      lines $ cmd_data)
-          else do
-            writeFile out_path (CLI.shTemplate ++ cmd_data)
-            printf "The commands have been written to file '%s'\n" out_path)
-
-  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
-         when (verbose > 3) $
-              do
-                printf "Original: mem=%d disk=%d\n" orig_mem orig_disk
-                printf "Final:    mem=%d disk=%d\n" final_mem final_disk
-  when oneline $
-         putStrLn $ formatOneline ini_cv (length ord_plc) fin_cv
--}
+  let Request rqtype nl il csf = request
+      new_nodes = case rqtype of
+                    Allocate xi reqn -> tryAlloc nl il xi reqn
+                    Relocate idx reqn exnodes ->
+                        tryReloc nl il idx reqn exnodes
+  let (ok, info, rn) = case new_nodes of
+               Ok sn -> (True, "Request successfull", map name sn)
+               Bad s -> (False, "Request failed: " ++ s, [])
+      resp = formatResponse ok info rn
+  putStrLn resp