From 7c14b50a38f00f49439cf3e42644dcd5f2703fc6 Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Sat, 2 Jul 2011 10:18:46 +0200
Subject: [PATCH] htools: allow different result types
This patch extends the previous patch changes to allow that each
Cluster function returns a different result type, as long as we have
an auxiliary function that processes that into the standard
IAllocResult type.
Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Guido Trotter <ultrotter@google.com>
---
htools/Ganeti/HTools/IAlloc.hs | 81 ++++++++++++++++------------------
1 file changed, 38 insertions(+), 43 deletions(-)
diff --git a/htools/Ganeti/HTools/IAlloc.hs b/htools/Ganeti/HTools/IAlloc.hs
index 05a807b56..d0b19b5c9 100644
--- a/htools/Ganeti/HTools/IAlloc.hs
+++ b/htools/Ganeti/HTools/IAlloc.hs
@@ -50,6 +50,9 @@ import Ganeti.HTools.ExtLoader (loadExternalData)
import Ganeti.HTools.Utils
import Ganeti.HTools.Types
+-- | Type alias for the result of an IAllocator call.
+type IAllocResult = (String, JSValue)
+
-- | Parse the basic specifications of an instance.
--
-- Instances in the cluster instance list and the instance in an
@@ -216,21 +219,6 @@ parseData body = do
| otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
return $ Request rqtype cdata
--- | Format the result
-formatRVal :: RqType -> [Node.AllocElement] -> JSValue
-formatRVal _ [] = JSArray []
-
-formatRVal (Evacuate _) elems =
- let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl)
- elems
- jsols = map (JSArray . map (JSString . toJSString)) sols
- in JSArray jsols
-
-formatRVal _ elems =
- let (_, _, nodes, _) = head elems
- nodes' = map Node.name nodes
- in JSArray $ map (JSString . toJSString) nodes'
-
-- | Formats the result into a valid IAllocator response message.
formatResponse :: Bool -- ^ Whether the request was successful
-> String -- ^ Information text
@@ -243,30 +231,43 @@ formatResponse success info result =
e_result = ("result", result)
in encodeStrict $ makeObj [e_success, e_info, e_result]
-processResults :: (Monad m) =>
- RqType -> Cluster.AllocSolution
- -> m Cluster.AllocSolution
-processResults _ (Cluster.AllocSolution { Cluster.asSolutions = [],
- Cluster.asLog = msgs }) =
- fail $ intercalate ", " msgs
+-- | Flatten the log of a solution into a string.
+describeSolution :: Cluster.AllocSolution -> String
+describeSolution = intercalate ", " . Cluster.asLog
-processResults (Evacuate _) as = return as
+-- | Convert evacuation results into the result format.
+formatEvacuate :: Cluster.AllocSolution -> Result IAllocResult
+formatEvacuate as = do
+ let info = describeSolution as
+ elems = Cluster.asSolutions as
+ when (null elems) $ fail info
+ let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl)
+ elems
+ jsols = map (JSArray . map (JSString . toJSString)) sols
+ return (info, JSArray jsols)
-processResults _ as =
- case Cluster.asSolutions as of
- _:[] -> return as
- _ -> fail "Internal error: multiple allocation solutions"
+-- | Convert allocation/relocation results into the result format.
+formatAllocate :: Cluster.AllocSolution -> Result IAllocResult
+formatAllocate as = do
+ let info = describeSolution as
+ case Cluster.asSolutions as of
+ [] -> fail info
+ (_, _, nodes, _):[] -> do
+ let nodes' = map Node.name nodes
+ return (info, JSArray $ map (JSString . toJSString) nodes')
+ _ -> fail "Internal error: multiple allocation solutions"
-- | Process a request and return new node lists
-processRequest :: Request
- -> Result Cluster.AllocSolution
+processRequest :: Request -> Result IAllocResult
processRequest request =
let Request rqtype (ClusterData gl nl il _) = request
in case rqtype of
- Allocate xi reqn -> Cluster.tryMGAlloc gl nl il xi reqn
- Relocate idx reqn exnodes -> Cluster.tryMGReloc gl nl il
- idx reqn exnodes
- Evacuate exnodes -> Cluster.tryMGEvac gl nl il exnodes
+ Allocate xi reqn ->
+ Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate
+ Relocate idx reqn exnodes ->
+ Cluster.tryMGReloc gl nl il idx reqn exnodes >>= formatAllocate
+ Evacuate exnodes ->
+ Cluster.tryMGEvac gl nl il exnodes >>= formatEvacuate
MultiReloc _ _ -> fail "multi-reloc not handled"
NodeEvacuate _ _ -> fail "node-evacuate not handled"
@@ -293,14 +294,8 @@ readRequest opts args = do
-- | Main iallocator pipeline.
runIAllocator :: Request -> String
runIAllocator request =
- let Request rq _ = request
- sols = processRequest request >>= processResults rq
- (ok, info, rn) =
- case sols of
- Ok as -> (True, "Request successful: " ++
- intercalate ", " (Cluster.asLog as),
- Cluster.asSolutions as)
- Bad s -> (False, "Request failed: " ++ s, [])
- result = formatRVal rq rn
- resp = formatResponse ok info result
- in resp
+ let (ok, info, result) =
+ case processRequest request of
+ Ok (msg, r) -> (True, "Request successful: " ++ msg, r)
+ Bad msg -> (False, "Request failed: " ++ msg, JSArray [])
+ in formatResponse ok info result
--
GitLab