+-- | Flatten the log of a solution into a string.
+describeSolution :: Cluster.AllocSolution -> String
+describeSolution = intercalate ", " . Cluster.asLog
+
+-- | Convert allocation/relocation results into the result format.
+formatAllocate :: Instance.List -> Cluster.AllocSolution -> Result IAllocResult
+formatAllocate il as = do
+ let info = describeSolution as
+ case Cluster.asSolutions as of
+ [] -> fail info
+ (nl, inst, nodes, _):[] ->
+ do
+ let il' = Container.add (Instance.idx inst) inst il
+ return (info, showJSON $ map Node.name nodes, nl, il')
+ _ -> fail "Internal error: multiple allocation solutions"
+
+-- | Convert a node-evacuation/change group result.
+formatNodeEvac :: Group.List
+ -> Node.List
+ -> Instance.List
+ -> (Node.List, Instance.List, Cluster.EvacSolution)
+ -> Result IAllocResult
+formatNodeEvac gl nl il (fin_nl, fin_il, es) =
+ let iname = Instance.name . flip Container.find il
+ nname = Node.name . flip Container.find nl
+ gname = Group.name . flip Container.find gl
+ fes = map (\(idx, msg) -> (iname idx, msg)) $ Cluster.esFailed es
+ mes = map (\(idx, gdx, ndxs) -> (iname idx, gname gdx, map nname ndxs))
+ $ Cluster.esMoved es
+ failed = length fes
+ moved = length mes
+ info = show failed ++ " instances failed to move and " ++ show moved ++
+ " were moved successfully"
+ in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es), fin_nl, fin_il)
+
+-- | Runs relocate for a single instance.
+--
+-- This is wrapper over the 'Cluster.tryNodeEvac' function that is run
+-- with a single instance (ours), and further it checks that the
+-- result it got (in the nodes field) is actually consistent, as
+-- tryNodeEvac is designed to output primarily an opcode list, not a
+-- node list.
+processRelocate :: Group.List -- ^ The group list
+ -> Node.List -- ^ The node list
+ -> Instance.List -- ^ The instance list
+ -> Idx -- ^ The index of the instance to move
+ -> Int -- ^ The number of nodes required
+ -> [Ndx] -- ^ Nodes which should not be used
+ -> Result (Node.List, Instance.List, [Ndx]) -- ^ Solution list
+processRelocate gl nl il idx 1 exndx = do
+ let orig = Container.find idx il
+ sorig = Instance.sNode orig
+ when (exndx /= [sorig]) $
+ -- FIXME: we can't use the excluded nodes here; the logic is
+ -- already _but only partially_ implemented in tryNodeEvac...
+ fail $ "Unsupported request: excluded nodes not equal to\
+ \ instance's secondary node (" ++ show sorig ++ " versus " ++
+ show exndx ++ ")"
+ (nl', il', esol) <- Cluster.tryNodeEvac gl nl il ChangeSecondary [idx]
+ nodes <- case lookup idx (Cluster.esFailed esol) of
+ Just msg -> fail msg
+ Nothing ->
+ case lookup idx (map (\(a, _, b) -> (a, b))
+ (Cluster.esMoved esol)) of
+ Nothing ->
+ fail "Internal error: lost instance idx during move"
+ Just n -> return n
+ let inst = Container.find idx il'
+ pnode = Instance.pNode inst
+ snode = Instance.sNode inst
+ when (snode == sorig) $
+ fail "Internal error: instance didn't change secondary node?!"
+ when (snode == pnode) $
+ fail "Internal error: selected primary as new secondary?!"
+
+ nodes' <- if (nodes == [pnode, snode])
+ then return [snode] -- only the new secondary is needed
+ else fail $ "Internal error: inconsistent node list (" ++
+ show nodes ++ ") versus instance nodes (" ++ show pnode ++
+ "," ++ show snode ++ ")"
+ return (nl', il', nodes')