From 669ea1322368786b85cd6846ae7000c5b530f5ed Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Tue, 1 Dec 2009 12:17:19 +0100
Subject: [PATCH] Read cluster tags in the IAllocator backend
---
Ganeti/HTools/IAlloc.hs | 6 ++++--
Ganeti/HTools/Loader.hs | 2 +-
hail.hs | 4 ++--
3 files changed, 7 insertions(+), 5 deletions(-)
diff --git a/Ganeti/HTools/IAlloc.hs b/Ganeti/HTools/IAlloc.hs
index be9d5063d..819021c8a 100644
--- a/Ganeti/HTools/IAlloc.hs
+++ b/Ganeti/HTools/IAlloc.hs
@@ -110,7 +110,9 @@ parseData body = do
iobj <- mapM (\(x,y) ->
asJSObject y >>= parseInstance ktn x . fromJSObject) idata
let (kti, il) = assignIndices iobj
- (map_n, map_i, _, csf) <- mergeData [] [] (nl, il, [])
+ -- cluster tags
+ ctags <- fromObj "cluster_tags" obj
+ (map_n, map_i, ptags, csf) <- mergeData [] [] (nl, il, ctags)
req_nodes <- fromObj "required_nodes" request
optype <- fromObj "type" request
rqtype <-
@@ -128,7 +130,7 @@ parseData body = do
ex_idex <- mapM (Container.findByName map_n) ex_nodes'
return $ Relocate ridx req_nodes (map Node.idx ex_idex)
other -> fail ("Invalid request type '" ++ other ++ "'")
- return $ Request rqtype map_n map_i csf
+ return $ Request rqtype map_n map_i ptags csf
-- | Formats the response into a valid IAllocator response message.
formatResponse :: Bool -- ^ Whether the request was successful
diff --git a/Ganeti/HTools/Loader.hs b/Ganeti/HTools/Loader.hs
index c1ad0a70f..385015eae 100644
--- a/Ganeti/HTools/Loader.hs
+++ b/Ganeti/HTools/Loader.hs
@@ -63,7 +63,7 @@ data RqType
deriving (Show)
-- | A complete request, as received from Ganeti.
-data Request = Request RqType Node.List Instance.List String
+data Request = Request RqType Node.List Instance.List [String] String
deriving (Show)
-- * Functions
diff --git a/hail.hs b/hail.hs
index 74c2ac279..56143c0b1 100644
--- a/hail.hs
+++ b/hail.hs
@@ -62,7 +62,7 @@ processResults (fstats, successes, sols) =
processRequest :: Request
-> Result Cluster.AllocSolution
processRequest request =
- let Request rqtype nl il _ = request
+ let Request rqtype nl il _ _ = request
in case rqtype of
Allocate xi reqn -> Cluster.tryAlloc nl il xi reqn
Relocate idx reqn exnodes -> Cluster.tryReloc nl il idx reqn exnodes
@@ -86,7 +86,7 @@ main = do
exitWith $ ExitFailure 1
Ok rq -> return rq
- let Request _ _ _ csf = request
+ let Request _ _ _ _ csf = request
sols = processRequest request >>= processResults
let (ok, info, rn) =
case sols of
--
GitLab