Read cluster tags in the IAllocator backend

diff --git a/Ganeti/HTools/IAlloc.hs b/Ganeti/HTools/IAlloc.hs
index be9d506..819021c 100644 (file)
--- 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 c1ad0a7..385015e 100644 (file)
--- 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 74c2ac2..56143c0 100644 (file)
--- 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