Merge branch 'stable-2.14' into stable-2.15
authorKlaus Aehlig <aehlig@google.com>
Thu, 12 Nov 2015 10:45:16 +0000 (11:45 +0100)
committerKlaus Aehlig <aehlig@google.com>
Thu, 12 Nov 2015 10:52:25 +0000 (11:52 +0100)
* stable-2.14
  Fix faulty iallocator type check
  Improve cfgupgrade output in case of errors

* stable-2.13
  Extend timeout for gnt-cluster renew-crypto
  Reduce flakyness of GetCmdline test on slow machines
  Remove duplicated words

* stable-2.12
  Revert "Also consider connection time out a network error"
  Clone lists before modifying
  Make lockConfig call retryable
  Return the correct error code in the post-upgrade script
  Make openssl refrain from DH altogether
  Fix upgrades of instances with missing creation time

* stable-2.11
  (no changes)

* stable-2.10
  Remove -X from hspace man page
  Make htools tolerate missing "dtotal" and "dfree" on luxi

Signed-off-by: Klaus Aehlig <aehlig@google.com>
Reviewed-by: Lisa Velden <velden@google.com>

115 files changed:
INSTALL
Makefile.am
NEWS
README
cabal/ganeti.template.cabal
configure.ac
devel/build_chroot
doc/design-2.15.rst [new file with mode: 0644]
doc/design-allocation-efficiency.rst [new file with mode: 0644]
doc/design-dedicated-allocation.rst [new file with mode: 0644]
doc/design-draft.rst
doc/design-multi-storage-htools.rst [new file with mode: 0644]
doc/design-shared-storage-redundancy.rst [new file with mode: 0644]
doc/hooks.rst
doc/iallocator.rst
doc/index.rst
doc/security.rst
doc/virtual-cluster.rst
lib/backend.py
lib/client/gnt_debug.py
lib/cmdlib/backup.py
lib/cmdlib/cluster/__init__.py
lib/cmdlib/common.py
lib/cmdlib/instance_create.py
lib/cmdlib/instance_helpervm.py [new file with mode: 0644]
lib/cmdlib/node.py
lib/metad.py [new file with mode: 0644]
lib/pathutils.py
lib/rapi/client.py
lib/rapi/rlib2.py
lib/tools/cfgupgrade.py
man/gnt-debug.rst
man/hail.rst
man/hbal.rst
man/hcheck.rst
qa/qa_cluster.py
qa/qa_config.py
qa/qa_node.py
src/Ganeti/Confd/ClientFunctions.hs
src/Ganeti/Confd/Server.hs
src/Ganeti/Config.hs
src/Ganeti/Constants.hs
src/Ganeti/Daemon.hs
src/Ganeti/DataCollectors.hs
src/Ganeti/DataCollectors/InstStatus.hs
src/Ganeti/DataCollectors/Types.hs
src/Ganeti/DataCollectors/XenCpuLoad.hs [new file with mode: 0644]
src/Ganeti/HTools/Backend/IAlloc.hs
src/Ganeti/HTools/Backend/MonD.hs [new file with mode: 0644]
src/Ganeti/HTools/Backend/Text.hs
src/Ganeti/HTools/CLI.hs
src/Ganeti/HTools/Cluster.hs
src/Ganeti/HTools/Cluster/Evacuate.hs [new file with mode: 0644]
src/Ganeti/HTools/Cluster/Metrics.hs [new file with mode: 0644]
src/Ganeti/HTools/Cluster/Moves.hs [new file with mode: 0644]
src/Ganeti/HTools/Cluster/Utils.hs [new file with mode: 0644]
src/Ganeti/HTools/Dedicated.hs [new file with mode: 0644]
src/Ganeti/HTools/ExtLoader.hs
src/Ganeti/HTools/GlobalN1.hs [new file with mode: 0644]
src/Ganeti/HTools/Loader.hs
src/Ganeti/HTools/Node.hs
src/Ganeti/HTools/PeerMap.hs
src/Ganeti/HTools/Program/Hail.hs
src/Ganeti/HTools/Program/Hbal.hs
src/Ganeti/HTools/Program/Hcheck.hs
src/Ganeti/HTools/Program/Hinfo.hs
src/Ganeti/HTools/Program/Hscan.hs
src/Ganeti/HTools/Program/Hspace.hs
src/Ganeti/HTools/Program/Hsqueeze.hs
src/Ganeti/JQScheduler.hs
src/Ganeti/JQScheduler/Filtering.hs
src/Ganeti/JSON.hs
src/Ganeti/Logging/WriterLog.hs
src/Ganeti/Metad/Config.hs
src/Ganeti/Metad/ConfigCore.hs [new file with mode: 0644]
src/Ganeti/Metad/ConfigServer.hs
src/Ganeti/Metad/Server.hs
src/Ganeti/Metad/WebServer.hs
src/Ganeti/Network.hs
src/Ganeti/Objects.hs
src/Ganeti/Objects/Disk.hs
src/Ganeti/Objects/Instance.hs
src/Ganeti/Objects/Lens.hs
src/Ganeti/Objects/Nic.hs
src/Ganeti/Query/Group.hs
src/Ganeti/Query/Instance.hs
src/Ganeti/Query/Network.hs
src/Ganeti/Query/Node.hs
src/Ganeti/Query/Query.hs
src/Ganeti/Query/Server.hs
src/Ganeti/Rpc.hs
src/Ganeti/Storage/Utils.hs
src/Ganeti/THH/Field.hs
src/Ganeti/THH/HsRPC.hs
src/Ganeti/Utils.hs
src/Ganeti/WConfd/Ssconf.hs
src/hs2py.hs
test/data/cluster_config_2.14.json [copied from test/data/cluster_config_2.13.json with 80% similarity]
test/data/htools/hail-alloc-dedicated-1.json [new file with mode: 0644]
test/data/htools/hail-multialloc-dedicated.json [new file with mode: 0644]
test/data/htools/shared-n1-failure.data [new file with mode: 0644]
test/hs/Test/Ganeti/HTools/Backend/MonD.hs [moved from test/hs/Test/Ganeti/HTools/ExtLoader.hs with 95% similarity]
test/hs/Test/Ganeti/HTools/Backend/Text.hs
test/hs/Test/Ganeti/HTools/Cluster.hs
test/hs/Test/Ganeti/JQScheduler.hs
test/hs/Test/Ganeti/Objects.hs
test/hs/Test/Ganeti/Query/Instance.hs
test/hs/Test/Ganeti/Utils.hs
test/hs/htest.hs
test/hs/shelltests/htools-hail.test
test/hs/shelltests/htools-hbal.test
test/hs/shelltests/htools-hcheck.test [new file with mode: 0644]
test/hs/shelltests/htools-single-group.test
test/py/cfgupgrade_unittest.py
test/py/ganeti.backend_unittest.py

diff --git a/INSTALL b/INSTALL
index 145b5fc..a07d0de 100644 (file)
--- a/INSTALL
+++ b/INSTALL
@@ -219,6 +219,9 @@ The extra dependencies for these are:
 
 - `snap-server` <http://hackage.haskell.org/package/snap-server>`_, version
   0.8.1 and above.
+- `case-insensitive`
+  <http://hackage.haskell.org/package/case-insensitive>`_, version
+  0.4.0.1 and above (it's also a dependency of ``snap-server``).
 - `PSQueue <http://hackage.haskell.org/package/PSQueue>`_,
   version 1.0 and above.
 
index d61df4c..8910b08 100644 (file)
@@ -142,6 +142,7 @@ HS_DIRS = \
        src/Ganeti/Hs2Py \
        src/Ganeti/HTools \
        src/Ganeti/HTools/Backend \
+       src/Ganeti/HTools/Cluster \
        src/Ganeti/HTools/Program \
        src/Ganeti/Hypervisor \
        src/Ganeti/Hypervisor/Xen \
@@ -385,6 +386,10 @@ built_python_base_sources = \
        lib/opcodes.py \
        lib/rpc/stub/wconfd.py
 
+if ENABLE_METADATA
+built_python_base_sources += lib/rpc/stub/metad.py
+endif
+
 built_python_sources = \
        $(nodist_pkgpython_PYTHON) \
        $(nodist_pkgpython_rpc_stub_PYTHON)
@@ -420,6 +425,10 @@ nodist_pkgpython_PYTHON = \
 nodist_pkgpython_rpc_stub_PYTHON = \
        lib/rpc/stub/wconfd.py
 
+if ENABLE_METADATA
+nodist_pkgpython_rpc_stub_PYTHON += lib/rpc/stub/metad.py
+endif
+
 nodist_pkgpython_bin_SCRIPTS = \
        $(nodist_pkglib_python_scripts)
 
@@ -448,6 +457,7 @@ pkgpython_PYTHON = \
        lib/locking.py \
        lib/luxi.py \
        lib/mcpu.py \
+       lib/metad.py \
        lib/netutils.py \
        lib/objects.py \
        lib/opcodes_base.py \
@@ -490,6 +500,7 @@ cmdlib_PYTHON = \
        lib/cmdlib/group.py \
        lib/cmdlib/instance.py \
        lib/cmdlib/instance_create.py \
+       lib/cmdlib/instance_helpervm.py \
        lib/cmdlib/instance_migration.py \
        lib/cmdlib/instance_operation.py \
        lib/cmdlib/instance_query.py \
@@ -645,6 +656,8 @@ docinput = \
        doc/design-2.12.rst \
        doc/design-2.13.rst \
        doc/design-2.14.rst \
+       doc/design-2.15.rst \
+       doc/design-allocation-efficiency.rst \
        doc/design-autorepair.rst \
        doc/design-bulk-create.rst \
        doc/design-ceph-ganeti-support.rst \
@@ -654,6 +667,7 @@ docinput = \
        doc/design-cpu-pinning.rst \
        doc/design-cpu-speed.rst \
        doc/design-daemons.rst \
+       doc/design-dedicated-allocation.rst \
        doc/design-device-uuid-name.rst \
        doc/design-disk-conversion.rst \
        doc/design-disks.rst \
@@ -677,6 +691,7 @@ docinput = \
        doc/design-monitoring-agent.rst \
        doc/design-move-instance-improvements.rst \
        doc/design-multi-reloc.rst \
+       doc/design-multi-storage-htools.rst \
        doc/design-multi-version-tests.rst \
        doc/design-network.rst \
        doc/design-network2.rst \
@@ -698,6 +713,7 @@ docinput = \
        doc/design-resource-model.rst \
        doc/design-restricted-commands.rst \
        doc/design-shared-storage.rst \
+       doc/design-shared-storage-redundancy.rst \
        doc/design-ssh-ports.rst \
        doc/design-storagetypes.rst \
        doc/design-sync-rate-throttling.rst \
@@ -881,17 +897,25 @@ HS_LIB_SRCS = \
        src/Ganeti/DataCollectors/Lv.hs \
        src/Ganeti/DataCollectors/Program.hs \
        src/Ganeti/DataCollectors/Types.hs \
+       src/Ganeti/DataCollectors/XenCpuLoad.hs \
        src/Ganeti/Errors.hs \
        src/Ganeti/HTools/AlgorithmParams.hs \
        src/Ganeti/HTools/Backend/IAlloc.hs \
        src/Ganeti/HTools/Backend/Luxi.hs \
+       src/Ganeti/HTools/Backend/MonD.hs \
        src/Ganeti/HTools/Backend/Rapi.hs \
        src/Ganeti/HTools/Backend/Simu.hs \
        src/Ganeti/HTools/Backend/Text.hs \
        src/Ganeti/HTools/CLI.hs \
        src/Ganeti/HTools/Cluster.hs \
+       src/Ganeti/HTools/Cluster/Evacuate.hs \
+       src/Ganeti/HTools/Cluster/Metrics.hs \
+       src/Ganeti/HTools/Cluster/Moves.hs \
+       src/Ganeti/HTools/Cluster/Utils.hs \
        src/Ganeti/HTools/Container.hs \
+       src/Ganeti/HTools/Dedicated.hs \
        src/Ganeti/HTools/ExtLoader.hs \
+       src/Ganeti/HTools/GlobalN1.hs \
        src/Ganeti/HTools/Graph.hs \
        src/Ganeti/HTools/Group.hs \
        src/Ganeti/HTools/Instance.hs \
@@ -1023,6 +1047,7 @@ endif
 if ENABLE_METADATA
 HS_LIB_SRCS += \
        src/Ganeti/Metad/Config.hs \
+       src/Ganeti/Metad/ConfigCore.hs \
        src/Ganeti/Metad/ConfigServer.hs \
        src/Ganeti/Metad/Server.hs \
        src/Ganeti/Metad/Types.hs \
@@ -1030,6 +1055,7 @@ HS_LIB_SRCS += \
 else
 EXTRA_DIST += \
        src/Ganeti/Metad/Config.hs \
+       src/Ganeti/Metad/ConfigCore.hs \
        src/Ganeti/Metad/ConfigServer.hs \
        src/Ganeti/Metad/Server.hs \
        src/Ganeti/Metad/Types.hs \
@@ -1046,12 +1072,12 @@ HS_TEST_SRCS = \
        test/hs/Test/Ganeti/Constants.hs \
        test/hs/Test/Ganeti/Daemon.hs \
        test/hs/Test/Ganeti/Errors.hs \
+       test/hs/Test/Ganeti/HTools/Backend/MonD.hs \
        test/hs/Test/Ganeti/HTools/Backend/Simu.hs \
        test/hs/Test/Ganeti/HTools/Backend/Text.hs \
        test/hs/Test/Ganeti/HTools/CLI.hs \
        test/hs/Test/Ganeti/HTools/Cluster.hs \
        test/hs/Test/Ganeti/HTools/Container.hs \
-       test/hs/Test/Ganeti/HTools/ExtLoader.hs \
        test/hs/Test/Ganeti/HTools/Graph.hs \
        test/hs/Test/Ganeti/HTools/Instance.hs \
        test/hs/Test/Ganeti/HTools/Loader.hs \
@@ -1660,6 +1686,7 @@ TEST_FILES = \
        test/data/htools/clean-nonzero-score.data \
        test/data/htools/common-suffix.data \
        test/data/htools/empty-cluster.data \
+       test/data/htools/hail-alloc-dedicated-1.json \
        test/data/htools/hail-alloc-drbd.json \
        test/data/htools/hail-alloc-invalid-network.json \
        test/data/htools/hail-alloc-invalid-twodisks.json \
@@ -1683,6 +1710,7 @@ TEST_FILES = \
        test/data/htools/hbal-migration-1.data \
        test/data/htools/hbal-migration-2.data \
        test/data/htools/hbal-migration-3.data \
+       test/data/htools/hail-multialloc-dedicated.json \
        test/data/htools/hbal-soft-errors.data \
        test/data/htools/hbal-split-insts.data \
        test/data/htools/hspace-groups-one.data \
@@ -1711,6 +1739,7 @@ TEST_FILES = \
        test/data/htools/hsqueeze-mixed-instances.data \
        test/data/htools/hsqueeze-overutilized.data \
        test/data/htools/hsqueeze-underutilized.data \
+       test/data/htools/shared-n1-failure.data \
        test/data/htools/unique-reboot-order.data \
        test/data/mond-data.txt \
        test/hs/shelltests/htools-balancing.test \
@@ -1720,6 +1749,7 @@ TEST_FILES = \
        test/hs/shelltests/htools-hail.test \
        test/hs/shelltests/htools-hbal-evac.test \
        test/hs/shelltests/htools-hbal.test \
+       test/hs/shelltests/htools-hcheck.test \
        test/hs/shelltests/htools-hroller.test \
        test/hs/shelltests/htools-hspace.test \
        test/hs/shelltests/htools-hsqueeze.test \
@@ -1761,6 +1791,7 @@ TEST_FILES = \
        test/data/cluster_config_2.11.json \
        test/data/cluster_config_2.12.json \
        test/data/cluster_config_2.13.json \
+       test/data/cluster_config_2.14.json \
        test/data/instance-minor-pairing.txt \
        test/data/instance-disks.txt \
        test/data/ip-addr-show-dummy0.txt \
@@ -2205,7 +2236,7 @@ epydoc.conf: epydoc.conf.in $(REPLACE_VARS_SED)
 
 vcs-version:
        if test -d .git; then \
-         git describe > $@; \
+         git describe | tr '"' - > $@; \
        elif test ! -f $@ ; then \
          echo "Cannot auto-generate $@ file"; exit 1; \
        fi
@@ -2230,7 +2261,7 @@ src/Ganeti/Version.hs: src/Ganeti/Version.hs.in \
        vcs-version $(built_base_sources)
        set -e; \
        VCSVER=`cat $(abs_top_srcdir)/vcs-version`; \
-       sed -e "s/%ver%/$$VCSVER/" < $< > $@
+       sed -e 's"%ver%"'"$$VCSVER"'"' < $< > $@
 
 src/Ganeti/Hs2Py/ListConstants.hs: src/Ganeti/Hs2Py/ListConstants.hs.in \
                                   src/Ganeti/Constants.hs \
@@ -2379,6 +2410,11 @@ lib/opcodes.py: Makefile src/hs2py lib/opcodes.py.in_before \
 lib/_generated_rpc.py: lib/rpc_defs.py $(BUILD_RPC) | $(built_base_sources) $(built_python_base_sources)
        PYTHONPATH=. $(RUN_IN_TEMPDIR) $(CURDIR)/$(BUILD_RPC) lib/rpc_defs.py > $@
 
+if ENABLE_METADATA
+lib/rpc/stub/metad.py: Makefile src/hs2py | stamp-directories
+       src/hs2py --metad-rpc > $@
+endif
+
 lib/rpc/stub/wconfd.py: Makefile src/hs2py | stamp-directories
        src/hs2py --wconfd-rpc > $@
 
diff --git a/NEWS b/NEWS
index c6f0739..d6e1820 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,85 @@ News
 ====
 
 
+Version 2.15.1
+--------------
+
+*(Released Mon, 7 Sep 2015)*
+
+New features
+~~~~~~~~~~~~
+
+- The ext template now allows userspace-only disks to be used
+
+Bugfixes
+~~~~~~~~
+
+- Fixed the silently broken 'gnt-instance replace-disks --ignore-ipolicy'
+  command.
+- User shutdown reporting can now be disabled on Xen using the
+  '--user-shutdown' flag.
+- Remove falsely reported communication NIC error messages on instance start.
+- Fix 'gnt-node migrate' behavior when no instances are present on a node.
+- Fix the multi-allocation functionality for non-DRBD instances.
+
+
+Version 2.15.0
+--------------
+
+*(Released Wed, 29 Jul 2015)*
+
+Incompatible/important changes
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+- In order to improve allocation efficiency when using DRBD, the cluster
+  metric now takes the total reserved memory into account. A consequence
+  of this change is that the best possible cluster metric is no longer 0.
+  htools(1) interprets minimal cluster scores to be offsets of the theoretical
+  lower bound, so only users interpreting the cluster score directly should
+  be affected.
+- This release contains a fix for the problem that different encodings in
+  SSL certificates can break RPC communication (issue 1094). The fix makes
+  it necessary to rerun 'gnt-cluster renew-crypto --new-node-certificates'
+  after the cluster is fully upgraded to 2.14.1
+
+New features
+~~~~~~~~~~~~
+
+- On dedicated clusters, hail will now favour allocations filling up
+  nodes efficiently over balanced allocations.
+
+New dependencies
+~~~~~~~~~~~~~~~~
+
+- The indirect dependency on Haskell package 'case-insensitive' is now
+  explicit.
+
+
+Version 2.15.0 rc1
+------------------
+
+*(Released Wed, 17 Jun 2015)*
+
+This was the first release candidate in the 2.15 series. All important
+changes are listed in the latest 2.15 entry.
+
+Known issues:
+~~~~~~~~~~~~~
+
+- Issue 1094: differences in encodings in SSL certificates due to
+  different OpenSSL versions can result in rendering a cluster
+  uncommunicative after a master-failover.
+
+
+Version 2.15.0 beta1
+--------------------
+
+*(Released Thu, 30 Apr 2015)*
+
+This was the second beta release in the 2.15 series. All important changes
+are listed in the latest 2.15 entry.
+
+
 Version 2.14.1
 --------------
 
diff --git a/README b/README
index 345ef2d..1c78531 100644 (file)
--- a/README
+++ b/README
@@ -1,4 +1,4 @@
-Ganeti 2.14
+Ganeti 2.15
 ===========
 
 For installation instructions, read the INSTALL and the doc/install.rst
index 3813087..3540949 100644 (file)
@@ -1,5 +1,5 @@
 name:                ganeti
-version:             2.14
+version:             2.15
 homepage:            http://www.ganeti.org
 license:             BSD2
 license-file:        COPYING
@@ -56,6 +56,7 @@ library
 
     , attoparsec                    >= 0.10.1.1   && < 0.13
     , base64-bytestring             >= 1.0.0.1    && < 1.1
+    , case-insensitive              >= 0.4.0.1    && < 1.3
     , Crypto                        >= 4.2.4      && < 4.3
     , curl                          >= 1.3.7      && < 1.4
     , hinotify                      >= 0.3.2      && < 0.4
index 42d458f..a3fe965 100644 (file)
@@ -1,6 +1,6 @@
 # Configure script for Ganeti
 m4_define([gnt_version_major], [2])
-m4_define([gnt_version_minor], [14])
+m4_define([gnt_version_minor], [15])
 m4_define([gnt_version_revision], [1])
 m4_define([gnt_version_suffix], [])
 m4_define([gnt_version_full],
index f1560c1..a73a4be 100755 (executable)
@@ -421,6 +421,14 @@ EOF
       build-essential
 
     in_chroot -- \
+      easy_install \
+        logilab-astng==0.24.1 \
+        logilab-common==0.58.3 \
+        mock==1.0.1 \
+        pylint==0.26.0 \
+        pep8==1.3.3
+
+    in_chroot -- \
       cabal update
 
      # Precise has network-2.4.0.0, which breaks, see
diff --git a/doc/design-2.15.rst b/doc/design-2.15.rst
new file mode 100644 (file)
index 0000000..6da41b4
--- /dev/null
@@ -0,0 +1,13 @@
+==================
+Ganeti 2.15 design
+==================
+
+The following designs have been partially implemented in Ganeti 2.15.
+
+- :doc:`design-configlock`
+- :doc:`design-shared-storage-redundancy`
+
+The following designs' implementations were completed in Ganeti 2.15.
+
+- :doc:`design-allocation-efficiency`
+- :doc:`design-dedicated-allocation`
diff --git a/doc/design-allocation-efficiency.rst b/doc/design-allocation-efficiency.rst
new file mode 100644 (file)
index 0000000..f375b27
--- /dev/null
@@ -0,0 +1,59 @@
+=========================================================================
+Improving allocation efficiency by considering the total reserved memory
+=========================================================================
+
+This document describes a change to the cluster metric to enhance
+the allocation efficiency of Ganeti's ``htools``.
+
+.. contents:: :depth: 4
+
+
+Current state and shortcomings
+==============================
+
+Ganeti's ``htools``, which typically make all allocation and balancing
+decisions, greedily try to improve the cluster metric. So it is important
+that the cluster metric faithfully reflects the objectives of these operations.
+Currently the cluster metric is composed of counting violations (instances on
+offline nodes, nodes that are not N+1 redundant, etc) and the sum of standard
+deviations of relative resource usage of the individual nodes. The latter
+component is to ensure that all nodes equally bear the load of the instances.
+This is reasonable for resources where the total usage is independent of
+its distribution, as it is the case for CPU, disk, and total RAM. It is,
+however, not true for reserved memory. By distributing its secondaries
+more widespread over the cluster, a node can reduce its reserved memory
+without increasing it on other nodes. Not taking this aspect into account
+has lead to quite inefficient allocation of instances on the cluster (see
+example below).
+
+Proposed changes
+================
+
+A new additive component is added to the cluster metric. It is the sum over
+all nodes of the fraction of reserved memory. This way, moves and allocations
+that reduce the amount of memory reserved to ensure N+1 redundancy are favored.
+
+Note that this component does not have the scaling of standard deviations of
+fractions, but, instead counts nodes reserved for N+1 redundancy. In an ideal
+allocation, this will not exceed 1. But bad allocations will violate this
+property. As waste of reserved memory is a more future-oriented problem than,
+e.g., current N+1 violations, we give the new component a relatively small
+weight of 0.25, so that counting current violations still dominate.
+
+Another consequence of this metric change is that the value 0 is no longer
+obtainable: as soon as we have DRBD instance, we have to reserve memory.
+However, in most cases only differences of scores influence decissions made.
+In the few cases, were absolute values of the cluster score are specified,
+they are interpreted as relative to the theoretical minimum of the reserved
+memory score.
+
+
+Example
+=======
+
+Consider the capacity of an empty cluster of 6 nodes, each capable of holding
+10 instances; this can be measured, e.g., by
+``hspace --simulate=p,6,204801,10241,21 --disk-template=drbd
+--standard-alloc=10240,1024,2``. Without the metric change 34 standard
+instances are allocated. With the metric change, 48 standard instances
+are allocated. This is a 41% increase in utilization.
diff --git a/doc/design-dedicated-allocation.rst b/doc/design-dedicated-allocation.rst
new file mode 100644 (file)
index 0000000..b0a81fc
--- /dev/null
@@ -0,0 +1,87 @@
+=================================
+Allocation for Partitioned Ganeti
+=================================
+
+.. contents:: :depth: 4
+
+
+Current state and shortcomings
+==============================
+
+The introduction of :doc:`design-partitioned` allowed to
+dedicate resources, in particular storage, exclusively to
+an instance. The advantage is that such instances have
+guaranteed latency that is not affected by other
+instances. Typically, those instances are created once
+and never moved. Also, typically large chunks (full, half,
+or quarter) of a node are handed out to individual
+partitioned instances.
+
+Ganeti's allocation strategy is to keep the cluster as
+balanced as possible. In particular, as long as empty nodes
+are available, new instances, regardless of their size,
+will be placed there. Therefore, if a couple of small
+instances are placed on the cluster first, it will no longer
+be possible to place a big instance on the cluster despite
+the total usage of the cluster being low.
+
+
+Proposed changes
+================
+
+We propose to change the allocation strategy of hail for
+node groups that have the ``exclusive_storage`` flag set,
+as detailed below; nothing will be changed for non-exclusive
+node groups. The new strategy will try to keep the cluster
+as available for new instances as possible.
+
+Dedicated Allocation Metric
+---------------------------
+
+The instance policy is a set of intervals in which the resources
+of the instance have to be. Typical choices for dedicated clusters
+have disjoint intervals with the same monotonicity in every dimension.
+In this case, the order is obvious. In order to make it well-defined
+in every case, we specify that we sort the intervals by the lower
+bound of the disk size. This is motivated by the fact that disk is
+the most critical aspect of partitioned Ganeti.
+
+For a node the *allocation vector* is the vector of, for each
+instance policy interval in decreasing order, the number of
+instances minimally compliant with that interval that still
+can be placed on that node. For the drbd template, it is assumed
+that all newly placed instances have new secondaries.
+
+The *lost-allocations vector* for an instance on a node is the
+difference of the allocation vectors for that node before and
+after placing that instance on that node. Lost-allocation vectors
+are ordered lexicographically, i.e., a loss of an allocation
+larger instance size dominates loss of allocations of smaller
+instance sizes.
+
+If allocating in a node group with ``exclusive_storage`` set
+to true, hail will try to minimise the pair of the lost-allocations
+vector and the remaining disk space on the node afer, ordered
+lexicographically.
+
+Example
+-------
+
+Consider the already mentioned scenario were only full, half, and quarter
+nodes are given to instances. Here, for the placement of a
+quarter-node--sized instance we would prefer a three-quarter-filled node (lost
+allocations: 0, 0, 1 and no left overs) over a quarter-filled node (lost
+allocations: 0, 0, 1 and half a node left over)
+over a half-filled node (lost allocations: 0, 1, 1) over an empty
+node (lost allocations: 1, 1, 1). A half-node sized instance, however,
+would prefer a half-filled node (lost allocations: 0, 1, 2 and no left-overs)
+over a quarter-filled node (lost allocations: 0, 1, 2 and a quarter node left
+over) over an empty node (lost allocations: 1, 1, 2).
+
+Note that the presence of additional policy intervals affects the preferences
+of instances of other sizes as well. This is by design, as additional available
+instance sizes make additional remaining node sizes attractive. If, in the
+given example, we would also allow three-quarter-node--sized instances, for
+a quarter-node--sized instance it would now be better to be placed on a
+half-full node (lost allocations: 0, 0, 1, 1) than on a quarter-filled
+node (lost allocations: 0, 1, 0, 1).
index 7aab851..09cf2ba 100644 (file)
@@ -2,7 +2,7 @@
 Design document drafts
 ======================
 
-.. Last updated for Ganeti 2.14
+.. Last updated for Ganeti 2.15
 
 .. toctree::
    :maxdepth: 2
@@ -24,6 +24,8 @@ Design document drafts
    design-sync-rate-throttling.rst
    design-network2.rst
    design-configlock.rst
+   design-multi-storage-htools.rst
+   design-shared-storage-redundancy.rst
    design-disks.rst
 
 .. vim: set textwidth=72 :
diff --git a/doc/design-multi-storage-htools.rst b/doc/design-multi-storage-htools.rst
new file mode 100644 (file)
index 0000000..3b347ab
--- /dev/null
@@ -0,0 +1,167 @@
+==================================================
+HTools support for multiple storage units per node
+==================================================
+
+.. contents:: :depth: 4
+
+This design document describes changes to hbal and related components (first
+and foremost LUXI), that will allow it to handle nodes that can't be considered
+monolithic in regard to disk layout, for example because they have multiple
+different storage units available.
+
+Current state and shortcomings
+==============================
+
+Currently the htools assume that there is one storage unit per node and that it can
+be arbitrarily split among instances. This leads to problems in clusters
+where multiple storage units are present: There might be 10GB DRBD and 10GB
+plain storage available on a node, for a total of 20GB. If an instance that
+uses 15GB of a single type of storage is requested, it can't actually fit on
+the node, but the current implementation of hail doesn't notice this.
+
+This behaviour is clearly wrong, but the problem doesn't arise often in current
+setup, due to the fact that instances currently only have a single
+storage type and that users typically use node groups to differentiate between
+different node storage layouts.
+
+For the node show action, RAPI only returns
+
+* ``dfree``: The total amount of free disk space
+* ``dtotal``: The total amount of disk space
+
+which is insufficient for the same reasons.
+
+
+Proposed changes
+================
+
+Definitions
+-----------
+
+* All disks have exactly one *desired storage unit*, which determines where and
+  how the disk can be stored. If the disk is transfered, the desired storage
+  unit remains unchanged. The desired storage unit includes specifics like the
+  volume group in the case of LVM based storage.
+* A *storage unit* is a specific storage location on a specific node. Storage
+  units have exactly one desired storage unit they can contain. A storage unit
+  further has an identifier (containing the storage type, a key and possibly
+  parameters), a total capacity, and a free capacity. A node cannot
+  contain multiple storage units of the same desired storage unit.
+* For the purposes of this document a *disk* has a desired storage unit and a size.
+* A *disk can be moved* to a node, if there is at least one storage unit on
+  that node which can contain the desired storage unit of the disk and if the
+  free capacity is at least the size of the disk.
+* An *instance can be moved* to a node, if all its disks can be moved there
+  one-by-one.
+
+LUXI and IAllocator protocol extension
+--------------------------------------
+
+The LUXI and IAllocator protocols are extended to include in the ``node``:
+
+* ``storage``: a list of objects (storage units) with
+  #. Storage unit, containing in order:
+
+     #. storage type
+     #. storage key (e.g. volume group name)
+     #. extra parameters (e.g. flag for exclusive storage) as a list.
+
+  #. Amount free in MiB
+  #. Amount total in MiB
+
+.. code-block:: javascript
+
+    {
+      "storage": [
+        { "sunit": ["drbd8", "xenvg", []]
+        , "free": 2000,
+        , "total": 4000
+        },
+        { "sunit": ["file", "/path/to/storage1", []]
+        , "free": 5000,
+        , "total": 10000
+        },
+        { "sunit": ["file", "/path/to/storage2", []]
+        , "free": 1000,
+        , "total": 20000
+        },
+        { "sunit": ["lvm-vg", "xenssdvg", [false]]
+        , "free": 1024,
+        , "total": 1024
+        }
+      ]
+    }
+
+is a node with an LVM volume group mirrored over DRBD, two file storage
+directories, one half full, one mostly full, and a non-mirrored volume group.
+
+The storage type ``drbd8`` needs to be added in order to differentiate between
+mirrored storage and non-mirrored storage.
+The storage key signals the volume group used and the storage unit takes no
+additional parameters.
+
+Text protocol extension
+-----------------------
+
+The same field is optionally present in the HTools text protocol:
+
+* a new "storage" column is added to the node section, which is a semicolon
+  separated list of comma separated fields in the order
+  #. ``free``
+  #. ``total``
+  #. ``sunit``, which in itself contains
+
+     #. the storage type
+     #. the storage key
+     #. extra arguments
+
+For example:
+
+    2000,4000,drbd,xenvg;5000,10000,file,/path/to/storage1;1000,20000;
+    [...]
+
+Interpretation
+--------------
+
+``hbal`` and ``hail`` will use this information only if available, if the data
+file doesn't contain the ``storage`` field the old algorithm is used.
+
+If the node information contains the ``storage`` field, hbal and hail will
+assume that only the space compatible with the disk's requirements is
+available. For an instance to fit a node, all it's disks need to fit there
+separately. For a disk to fit a node, a storage unit of the type of
+the disk needs to have enough free space to contain it. The total free storage
+is not taken into consideration.
+
+Ignoring the old information will in theory introduce a backwards
+incompatibility: If the total free storage is smaller than to the sum of the
+free storage reported in the ``storage`` field a previously illegal move will
+become legal.
+
+Balancing
+---------
+
+In order to determine a storage location for an instance, we collect analogous
+metrics to the current total node free space metric -- namely the standard deviation
+statistic of the free space per storage unit.
+
+The *standard deviation metric* of a desired storage unit is the sample standard
+deviation of the percentage of free space of storage units compatible.
+
+The *full storage metric* is a average of the standard deviation metrics of the
+desired storage units.
+
+This is backwards compatible in-so-far as that
+
+#. For a single storage unit per node it will have the same value.
+#. The weight of the storage versus the other metrics remains unchanged.
+
+Further this retains the property that scarce resources with low total will
+tend to have bigger impact on the metric than those with large totals, because
+in latter case the relative differences will not make for a large standard
+deviation.
+
+Ignoring nodes that do not contain the desired storage unit additionally
+boosts the importance of the scarce desired storage units, because having more
+storage units of a desired storage unit will tend to make the standard
+deviation metric smaller.
diff --git a/doc/design-shared-storage-redundancy.rst b/doc/design-shared-storage-redundancy.rst
new file mode 100644 (file)
index 0000000..14e8bc1
--- /dev/null
@@ -0,0 +1,73 @@
+=================================
+N+1 redundancy for shared storage
+=================================
+
+.. contents:: :depth: 4
+
+This document describes how N+1 redundancy is achieved
+for instanes using shared storage.
+
+
+Current state and shortcomings
+==============================
+
+For instances with DRBD as disk template, in case of failures
+of their primary node, there is only one node where the instance
+can be restarted immediately. Therefore, ``htools`` reserve enough
+memory on that node to cope with failure of a single node.
+For instances using shared storage, however, they can be restarted
+on any node---implying that on no particular node memory has to
+be reserved. This, however, motivated the current state where no
+memory is reserved at all. And even a large cluster can run out
+of capacity.
+
+Proposed changes
+================
+
+Definition on N+1 redundancy in the presence of shared storage
+--------------------------------------------------------------
+
+A cluster is considered N+1 redundant, if, for every node, all
+DRBD instances can be migrated out and then all shared-storage
+instances can be relocated to a different node without moving
+instances on other nodes. This is precisely the operation done
+after a node breaking. Obviously, simulating failure and evacuation
+for every single node is an expensive operation.
+
+Basic Considerations
+--------------------
+
+For DRBD, keeping N+1 redundancy is affected by moving instances and
+balancing the cluster. Moreover, taking is into account for balancing
+can help :doc:`design-allocation-efficiency`. Hence, N+1 redundancy
+for DRBD is to be taken into account for all choices affecting instance
+location, including instance allocation and balancing.
+
+For shared-storage instances, they can move everywhere within the
+node group. So, in practise, this is mainly a question of capacity
+planing, especially is most instances have the same size. Nevertheless,
+offcuts if instances don't fill a node entirely may not be ignored.
+
+
+Modifications to existing tools
+-------------------------------
+
+- ``hail`` will compute and rank possible allocations as usual. However,
+  before returing a choice it will filter out allocations that are
+  not N+1 redundant.
+
+- Normal ``gnt-cluster verify`` will not be changed; in particular,
+  it will still check for DRBD N+1 redundancy, but not for shared
+  storage N+1 redundancy. However, ``hcheck`` will verify shared storage
+  N+1 redundancy and report it that fails.
+
+- ``hbal`` will consider and rank moves as usual. However, before deciding
+  on the next move, it will filter out those moves that lead from a
+  shared storage N+1 redundant configuration into one that isn't.
+
+- ``hspace`` computing the capacity for DRBD instances will be unchanged.
+  For shared storage instances, however, it will first evacuate one node
+  and then compute capacity as normal pretending that node was offline.
+  While this technically deviates from interatively doing what hail does,
+  it should still give a reasonable estimate of the cluster capacity without
+  significantly increasing the algorithmic complexity.
index f7a0a25..dfd20a0 100644 (file)
@@ -1,7 +1,7 @@
 Ganeti customisation using hooks
 ================================
 
-Documents Ganeti version 2.14
+Documents Ganeti version 2.15
 
 .. contents::
 
index c5c360f..13319e8 100644 (file)
@@ -1,7 +1,7 @@
 Ganeti automatic instance allocation
 ====================================
 
-Documents Ganeti version 2.14
+Documents Ganeti version 2.15
 
 .. contents::
 
index 28b37a0..16d0301 100644 (file)
@@ -80,6 +80,7 @@ and draft versions (which are either incomplete or not implemented).
    design-2.12.rst
    design-2.13.rst
    design-2.14.rst
+   design-2.15.rst
 
 Draft designs
 -------------
@@ -94,12 +95,14 @@ Draft designs
    admin.rst
    cluster-merge.rst
    cluster-keys-replacement.rst
+   design-allocation-efficiency.rst
    design-autorepair.rst
    design-bulk-create.rst
    design-chained-jobs.rst
    design-cmdlib-unittests.rst
    design-cpu-speed.rst
    design-cpu-pinning.rst
+   design-dedicated-allocation.rst
    design-device-uuid-name.rst
    design-daemons.rst
    design-disk-conversion.rst
index da66565..ab8eea1 100644 (file)
@@ -1,7 +1,7 @@
 Security in Ganeti
 ==================
 
-Documents Ganeti version 2.14
+Documents Ganeti version 2.15
 
 Ganeti was developed to run on internal, trusted systems. As such, the
 security model is all-or-nothing.
index 7fdfc45..c49f9a6 100644 (file)
@@ -1,7 +1,7 @@
 Virtual cluster support
 =======================
 
-Documents Ganeti version 2.14
+Documents Ganeti version 2.15
 
 .. contents::
 
index f23b5ec..f891ef6 100644 (file)
@@ -56,12 +56,12 @@ import random
 import re
 import shutil
 import signal
-import socket
 import stat
 import tempfile
 import time
 import zlib
 import copy
+import contextlib
 
 from ganeti import errors
 from ganeti import http
@@ -86,8 +86,7 @@ from ganeti import ht
 from ganeti.storage.base import BlockDev
 from ganeti.storage.drbd import DRBD8
 from ganeti import hooksmaster
-from ganeti.rpc import transport
-from ganeti.rpc.errors import NoMasterError, TimeoutError
+import ganeti.metad as metad
 
 
 _BOOT_ID_PATH = "/proc/sys/kernel/random/boot_id"
@@ -1687,6 +1686,9 @@ def RemoveNodeSshKey(node_uuid, node_name,
         if node not in online_nodes:
           logging.debug("Skipping offline node '%s'.", node)
           continue
+        if node == node_name:
+          logging.debug("Skipping node itself '%s'.", node_name)
+          continue
         ssh_port = ssh_port_map.get(node)
         if not ssh_port:
           raise errors.OpExecError("No SSH port information available for"
@@ -3001,31 +3003,8 @@ def ModifyInstanceMetadata(metadata):
     if result.failed:
       raise errors.HypervisorError("Failed to start metadata daemon")
 
-  def _Connect():
-    return transport.Transport(pathutils.SOCKET_DIR + "/ganeti-metad",
-                               allow_non_master=True)
-
-  retries = 5
-
-  while True:
-    try:
-      trans = utils.Retry(_Connect, 1.0, constants.LUXI_DEF_CTMO)
-      break
-    except utils.RetryTimeout:
-      raise TimeoutError("Connection to metadata daemon timed out")
-    except (socket.error, NoMasterError), err:
-      if retries == 0:
-        logging.error("Failed to connect to the metadata daemon",
-                      exc_info=True)
-        raise TimeoutError("Failed to connect to metadata daemon: %s" % err)
-      else:
-        retries -= 1
-
-  data = serializer.DumpJson(metadata,
-                             private_encoder=serializer.EncodeWithPrivateFields)
-
-  trans.Send(data)
-  trans.Close()
+  with contextlib.closing(metad.Client()) as client:
+    client.UpdateConfig(metadata)
 
 
 def BlockdevCreate(disk, size, owner, on_primary, info, excl_stor):
index 9b36ceb..d05fbc2 100644 (file)
@@ -47,6 +47,7 @@ from ganeti import utils
 from ganeti import errors
 from ganeti import compat
 from ganeti import ht
+from ganeti import metad
 from ganeti import wconfd
 
 
@@ -632,6 +633,29 @@ def ListLocks(opts, args): # pylint: disable=W0613
   return 0
 
 
+def Metad(opts, args): # pylint: disable=W0613
+  """Send commands to Metad.
+
+  @param opts: the command line options selected by the user
+  @type args: list
+  @param args: the command to send, followed by the command-specific arguments
+  @rtype: int
+  @return: the desired exit code
+
+  """
+  if args[0] == "echo":
+    if len(args) != 2:
+      ToStderr("Command 'echo' takes only precisely argument.")
+      return 1
+    result = metad.Client().Echo(args[1])
+    print "Answer: %s" % (result,)
+  else:
+    ToStderr("Command '%s' not supported", args[0])
+    return 1
+
+  return 0
+
+
 def Wconfd(opts, args): # pylint: disable=W0613
   """Send commands to WConfD.
 
@@ -768,6 +792,9 @@ commands = {
   "wconfd": (
     Wconfd, [ArgUnknown(min=1)], [],
     "<cmd> <args...>", "Directly talk to WConfD"),
+  "metad": (
+    Metad, [ArgUnknown(min=1)], [],
+    "<cmd> <args...>", "Directly talk to Metad"),
   }
 
 #: dictionary with aliases for commands
index 3486291..84ceecf 100644 (file)
@@ -39,13 +39,12 @@ from ganeti import errors
 from ganeti import locking
 from ganeti import masterd
 from ganeti import utils
-from ganeti.utils import retry
 
 from ganeti.cmdlib.base import NoHooksLU, LogicalUnit
-from ganeti.cmdlib.common import CheckNodeOnline, ExpandNodeUuidAndName, \
-  IsInstanceRunning, DetermineImageSize
+from ganeti.cmdlib.common import CheckNodeOnline, ExpandNodeUuidAndName
+from ganeti.cmdlib.instance_helpervm import RunWithHelperVM
 from ganeti.cmdlib.instance_storage import StartInstanceDisks, \
-  ShutdownInstanceDisks, TemporaryDisk, ImageDisks
+  ShutdownInstanceDisks
 from ganeti.cmdlib.instance_utils import GetClusterDomainSecret, \
   BuildInstanceHookEnvByObject, CheckNodeNotDrained, RemoveInstance, \
   CheckCompressionTool
@@ -374,54 +373,16 @@ class LUBackupExport(LogicalUnit):
     assert self.op.zeroing_timeout_per_mib is not None
 
     zeroing_image = self.cfg.GetZeroingImage()
-    src_node_uuid = self.instance.primary_node
-
-    try:
-      disk_size = DetermineImageSize(self, zeroing_image, src_node_uuid)
-    except errors.OpExecError, err:
-      raise errors.OpExecError("Could not create temporary disk for zeroing:"
-                               " %s", err)
 
     # Calculate the sum prior to adding the temporary disk
     instance_disks_size_sum = self._InstanceDiskSizeSum()
+    timeout = self.op.zeroing_timeout_fixed + \
+              self.op.zeroing_timeout_per_mib * instance_disks_size_sum
 
-    with TemporaryDisk(self,
-                       self.instance,
-                       [(constants.DT_PLAIN, constants.DISK_RDWR, disk_size)],
-                       feedback_fn):
-      feedback_fn("Activating instance disks")
-      StartInstanceDisks(self, self.instance, False)
-
-      feedback_fn("Imaging disk with zeroing image")
-      ImageDisks(self, self.instance, zeroing_image)
-
-      feedback_fn("Starting instance with zeroing image")
-      result = self.rpc.call_instance_start(src_node_uuid,
-                                            (self.instance, [], []),
-                                            False, self.op.reason)
-      result.Raise("Could not start instance %s when using the zeroing image "
-                   "%s" % (self.instance.name, zeroing_image))
-
-      # First wait for the instance to start up
-      running_check = lambda: IsInstanceRunning(self, self.instance,
-                                                prereq=False)
-      instance_up = retry.SimpleRetry(True, running_check, 5.0,
-                                      self.op.shutdown_timeout)
-      if not instance_up:
-        raise errors.OpExecError("Could not boot instance when using the "
-                                 "zeroing image %s" % zeroing_image)
-
-      feedback_fn("Instance is up, now awaiting shutdown")
-
-      # Then for it to be finished, detected by its shutdown
-      timeout = self.op.zeroing_timeout_fixed + \
-                self.op.zeroing_timeout_per_mib * instance_disks_size_sum
-      instance_up = retry.SimpleRetry(False, running_check, 20.0, timeout)
-      if instance_up:
-        self.LogWarning("Zeroing not completed prior to timeout; instance will"
-                        "be shut down forcibly")
-
-    feedback_fn("Zeroing completed!")
+    RunWithHelperVM(self, self.instance, zeroing_image,
+                    self.op.shutdown_timeout, timeout,
+                    log_prefix="Zeroing free disk space",
+                    feedback_fn=feedback_fn)
 
   def StartInstance(self, feedback_fn, src_node_uuid):
     """Send the node instructions to start the instance.
index 51474d6..cfe5feb 100644 (file)
@@ -1667,7 +1667,12 @@ class LUClusterSetParams(LogicalUnit):
     if self.op.candidate_pool_size is not None:
       self.cluster.candidate_pool_size = self.op.candidate_pool_size
       # we need to update the pool size here, otherwise the save will fail
-      AdjustCandidatePool(self, [])
+      master_node = self.cfg.GetMasterNode()
+      potential_master_candidates = self.cfg.GetPotentialMasterCandidates()
+      modify_ssh_setup = self.cfg.GetClusterInfo().modify_ssh_setup
+      AdjustCandidatePool(
+          self, [], master_node, potential_master_candidates, feedback_fn,
+          modify_ssh_setup)
 
     if self.op.max_running_jobs is not None:
       self.cluster.max_running_jobs = self.op.max_running_jobs
index fa2bf77..1d79a3e 100644 (file)
@@ -476,9 +476,35 @@ def CheckHVParams(lu, node_uuids, hvname, hvparams):
                lu.cfg.GetNodeName(node_uuid))
 
 
-def AdjustCandidatePool(lu, exceptions):
+def AddMasterCandidateSshKey(
+    lu, master_node, node, potential_master_candidates, feedback_fn):
+  ssh_result = lu.rpc.call_node_ssh_key_add(
+    [master_node], node.uuid, node.name,
+    potential_master_candidates,
+    True, # add node's key to all node's 'authorized_keys'
+    True, # all nodes are potential master candidates
+    False) # do not update the node's public keys
+  ssh_result[master_node].Raise(
+    "Could not update the SSH setup of node '%s' after promotion"
+    " (UUID: %s)." % (node.name, node.uuid))
+  WarnAboutFailedSshUpdates(ssh_result, master_node, feedback_fn)
+
+
+def AdjustCandidatePool(
+    lu, exceptions, master_node, potential_master_candidates, feedback_fn,
+    modify_ssh_setup):
   """Adjust the candidate pool after node operations.
 
+  @type master_node: string
+  @param master_node: name of the master node
+  @type potential_master_candidates: list of string
+  @param potential_master_candidates: list of node names of potential master
+      candidates
+  @type feedback_fn: function
+  @param feedback_fn: function emitting user-visible output
+  @type modify_ssh_setup: boolean
+  @param modify_ssh_setup: whether or not the ssh setup can be modified.
+
   """
   mod_list = lu.cfg.MaintainCandidatePool(exceptions)
   if mod_list:
@@ -487,6 +513,10 @@ def AdjustCandidatePool(lu, exceptions):
     for node in mod_list:
       lu.context.ReaddNode(node)
       AddNodeCertToCandidateCerts(lu, lu.cfg, node.uuid)
+      if modify_ssh_setup:
+        AddMasterCandidateSshKey(
+            lu, master_node, node, potential_master_candidates, feedback_fn)
+
   mc_now, mc_max, _ = lu.cfg.GetMasterCandidateStats(exceptions)
   if mc_now > mc_max:
     lu.LogInfo("Note: more nodes are candidates (%d) than desired (%d)" %
index cb2a6da..aec9d9f 100644 (file)
@@ -45,7 +45,6 @@ from ganeti import netutils
 from ganeti import objects
 from ganeti import pathutils
 from ganeti import utils
-from ganeti.utils import retry
 from ganeti import serializer
 
 from ganeti.cmdlib.base import LogicalUnit
@@ -56,14 +55,14 @@ from ganeti.cmdlib.common import \
   IsExclusiveStorageEnabledNode, CheckHVParams, CheckOSParams, \
   ExpandNodeUuidAndName, \
   IsValidDiskAccessModeCombination, \
-  CheckDiskTemplateEnabled, CheckIAllocatorOrNode, CheckOSImage, \
-  IsInstanceRunning, DetermineImageSize
+  CheckDiskTemplateEnabled, CheckIAllocatorOrNode, CheckOSImage
+from ganeti.cmdlib.instance_helpervm import RunWithHelperVM
 from ganeti.cmdlib.instance_storage import CalculateFileStorageDir, \
   CheckNodesFreeDiskPerVG, CheckRADOSFreeSpace, CheckSpindlesExclusiveStorage, \
   ComputeDiskSizePerVG, CreateDisks, \
-  GenerateDiskTemplate, CommitDisks, StartInstanceDisks, \
+  GenerateDiskTemplate, CommitDisks, \
   WaitForSync, ComputeDisks, \
-  TemporaryDisk, ImageDisks, WipeDisks
+  ImageDisks, WipeDisks
 from ganeti.cmdlib.instance_utils import \
   CheckNodeNotDrained, CopyLockList, \
   ReleaseLocks, CheckNodeVmCapable, \
@@ -1405,8 +1404,6 @@ class LUInstanceCreate(LogicalUnit):
       raise errors.OpExecError("Cannot create install instance because an"
                                " install image has not been specified")
 
-    disk_size = DetermineImageSize(self, install_image, instance.primary_node)
-
     env = self.GetOsInstallPackageEnvironment(
       instance,
       constants.OS_SCRIPT_CREATE_UNTRUSTED)
@@ -1415,41 +1412,11 @@ class LUInstanceCreate(LogicalUnit):
                    osparams_private=self.op.osparams_private,
                    osparams_secret=self.op.osparams_secret)
 
-    with TemporaryDisk(self,
-                       instance,
-                       [(constants.DT_PLAIN, constants.DISK_RDWR, disk_size)],
-                       feedback_fn):
-      feedback_fn("Activating instance disks")
-      StartInstanceDisks(self, instance, False)
-
-      feedback_fn("Imaging disk with install image")
-      ImageDisks(self, instance, install_image)
-
-      feedback_fn("Starting instance with install image")
-      result = self.rpc.call_instance_start(instance.primary_node,
-                                            (instance, [], []),
-                                            False, self.op.reason)
-      result.Raise("Could not start instance '%s' with the install image '%s'"
-                   % (instance.name, install_image))
-
-      # First wait for the instance to start up
-      running_check = lambda: IsInstanceRunning(self, instance, prereq=False)
-      instance_up = retry.SimpleRetry(True, running_check, 5.0,
-                                      self.op.helper_startup_timeout)
-      if not instance_up:
-        raise errors.OpExecError("Could not boot instance using install image"
-                                 " '%s'" % install_image)
-
-      feedback_fn("Instance is up, now awaiting shutdown")
-
-      # Then for it to be finished, detected by its shutdown
-      instance_up = retry.SimpleRetry(False, running_check, 20.0,
-                                      self.op.helper_shutdown_timeout)
-      if instance_up:
-        self.LogWarning("Installation not completed prior to timeout, shutting"
-                        " down instance forcibly")
-
-    feedback_fn("Installation complete")
+    RunWithHelperVM(self, instance, install_image,
+                    self.op.helper_startup_timeout,
+                    self.op.helper_shutdown_timeout,
+                    log_prefix="Running OS create script",
+                    feedback_fn=feedback_fn)
 
   def Exec(self, feedback_fn):
     """Create and add the instance to the cluster.
diff --git a/lib/cmdlib/instance_helpervm.py b/lib/cmdlib/instance_helpervm.py
new file mode 100644 (file)
index 0000000..5fba97b
--- /dev/null
@@ -0,0 +1,172 @@
+#
+#
+
+# Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Google Inc.
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright notice,
+# this list of conditions and the following disclaimer.
+#
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+# PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
+# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+
+"""Functions for running helper virtual machines to perform tasks on instances.
+
+"""
+
+import contextlib
+
+from ganeti import constants
+from ganeti import errors
+from ganeti.utils import retry
+
+from ganeti.cmdlib.common import IsInstanceRunning, DetermineImageSize
+from ganeti.cmdlib.instance_storage import StartInstanceDisks, \
+  TemporaryDisk, ImageDisks
+
+
+@contextlib.contextmanager
+def HelperVM(lu, instance, vm_image, startup_timeout, vm_timeout,
+             log_prefix=None, feedback_fn=None):
+  """Runs a given helper VM for a given instance.
+
+  @type lu: L{LogicalUnit}
+  @param lu: the lu on whose behalf we execute
+  @type instance: L{objects.Instance}
+  @param instance: the instance definition
+  @type vm_image: string
+  @param vm_image: the name of the helper VM image to dump on a temporary disk
+  @type startup_timeout: int
+  @param startup_timeout: how long to wait for the helper VM to start up
+  @type vm_timeout: int
+  @param vm_timeout: how long to wait for the helper VM to finish its work
+  @type log_prefix: string
+  @param log_prefix: a prefix for all log messages
+  @type feedback_fn: function
+  @param feedback_fn: Function used to log progress
+
+  """
+  if log_prefix:
+    add_prefix = lambda msg: "%s: %s" % (log_prefix, msg)
+  else:
+    add_prefix = lambda msg: msg
+
+  if feedback_fn is not None:
+    log_feedback = lambda msg: feedback_fn(add_prefix(msg))
+  else:
+    log_feedback = lambda _: None
+
+  try:
+    disk_size = DetermineImageSize(lu, vm_image, instance.primary_node)
+  except errors.OpExecError, err:
+    raise errors.OpExecError("Could not create temporary disk: %s", err)
+
+  with TemporaryDisk(lu,
+                     instance,
+                     [(constants.DT_PLAIN, constants.DISK_RDWR, disk_size)],
+                     log_feedback):
+    log_feedback("Activating helper VM's temporary disks")
+    StartInstanceDisks(lu, instance, False)
+
+    log_feedback("Imaging temporary disks with image %s" % (vm_image, ))
+    ImageDisks(lu, instance, vm_image)
+
+    log_feedback("Starting helper VM")
+    result = lu.rpc.call_instance_start(instance.primary_node,
+                                        (instance, [], []),
+                                        False, lu.op.reason)
+    result.Raise(add_prefix("Could not start helper VM with image %s" %
+                            (vm_image, )))
+
+    # First wait for the instance to start up
+    running_check = lambda: IsInstanceRunning(lu, instance, prereq=False)
+    instance_up = retry.SimpleRetry(True, running_check, 5.0,
+                                    startup_timeout)
+    if not instance_up:
+      raise errors.OpExecError(add_prefix("Could not boot instance using"
+                                          " image %s" % (vm_image, )))
+
+    log_feedback("Helper VM is up")
+
+    def cleanup():
+      log_feedback("Waiting for helper VM to finish")
+
+      # Then for it to be finished, detected by its shutdown
+      instance_up = retry.SimpleRetry(False, running_check, 20.0, vm_timeout)
+      if instance_up:
+        lu.LogWarning(add_prefix("Helper VM has not finished within the"
+                                 " timeout; shutting it down forcibly"))
+        return \
+          lu.rpc.call_instance_shutdown(instance.primary_node,
+                                        instance,
+                                        constants.DEFAULT_SHUTDOWN_TIMEOUT,
+                                        lu.op.reason)
+      else:
+        return None
+
+    # Run the inner block and handle possible errors
+    try:
+      yield
+    except Exception:
+      # if the cleanup failed for some reason, log it and just re-raise
+      result = cleanup()
+      if result:
+        result.Warn(add_prefix("Could not shut down helper VM with image"
+                               " %s within timeout" % (vm_image, )))
+        log_feedback("Error running helper VM with image %s" %
+                     (vm_image, ))
+      raise
+    else:
+      result = cleanup()
+      # if the cleanup failed for some reason, throw an exception
+      if result:
+        result.Raise(add_prefix("Could not shut down helper VM with image %s"
+                                " within timeout" % (vm_image, )))
+        raise errors.OpExecError("Error running helper VM with image %s" %
+                                 (vm_image, ))
+
+  log_feedback("Helper VM execution completed")
+
+
+def RunWithHelperVM(lu, instance, vm_image, startup_timeout, vm_timeout,
+                    log_prefix=None, feedback_fn=None):
+  """Runs a given helper VM for a given instance.
+
+  @type lu: L{LogicalUnit}
+  @param lu: the lu on whose behalf we execute
+  @type instance: L{objects.Instance}
+  @param instance: the instance definition
+  @type vm_image: string
+  @param vm_image: the name of the helper VM image to dump on a temporary disk
+  @type startup_timeout: int
+  @param startup_timeout: how long to wait for the helper VM to start up
+  @type vm_timeout: int
+  @param vm_timeout: how long to wait for the helper VM to finish its work
+  @type log_prefix: string
+  @param log_prefix: a prefix for all log messages
+  @type feedback_fn: function
+  @param feedback_fn: Function used to log progress
+
+
+  """
+  with HelperVM(lu, instance, vm_image, startup_timeout, vm_timeout,
+                log_prefix=log_prefix, feedback_fn=feedback_fn):
+    pass
index 569fa25..c0eccce 100644 (file)
@@ -53,7 +53,7 @@ from ganeti.cmdlib.common import CheckParamsNotGlobal, \
   GetWantedNodes, MapInstanceLvsToNodes, RunPostHook, \
   FindFaultyInstanceDisks, CheckStorageTypeEnabled, GetClientCertDigest, \
   AddNodeCertToCandidateCerts, RemoveNodeCertFromCandidateCerts, \
-  EnsureKvmdOnNodes, WarnAboutFailedSshUpdates
+  EnsureKvmdOnNodes, WarnAboutFailedSshUpdates, AddMasterCandidateSshKey
 
 
 def _DecideSelfPromotion(lu, exceptions=None):
@@ -829,6 +829,9 @@ class LUNodeSetParams(LogicalUnit):
 
     # this will trigger configuration file update, if needed
     self.cfg.Update(node, feedback_fn)
+    master_node = self.cfg.GetMasterNode()
+    potential_master_candidates = self.cfg.GetPotentialMasterCandidates()
+    modify_ssh_setup = self.cfg.GetClusterInfo().modify_ssh_setup
 
     if self.new_role != self.old_role:
       new_flags = self._R2F[self.new_role]
@@ -849,7 +852,9 @@ class LUNodeSetParams(LogicalUnit):
 
       # we locked all nodes, we adjust the CP before updating this node
       if self.lock_all:
-        AdjustCandidatePool(self, [node.uuid])
+        AdjustCandidatePool(
+            self, [node.uuid], master_node, potential_master_candidates,
+            feedback_fn, modify_ssh_setup)
 
       # if node gets promoted, grant RPC priviledges
       if self.new_role == self._ROLE_CANDIDATE:
@@ -865,9 +870,7 @@ class LUNodeSetParams(LogicalUnit):
     if [self.old_role, self.new_role].count(self._ROLE_CANDIDATE) == 1:
       self.context.ReaddNode(node)
 
-      if self.cfg.GetClusterInfo().modify_ssh_setup:
-        potential_master_candidates = self.cfg.GetPotentialMasterCandidates()
-        master_node = self.cfg.GetMasterNode()
+      if modify_ssh_setup:
         if self.old_role == self._ROLE_CANDIDATE:
           master_candidate_uuids = self.cfg.GetMasterCandidateUuids()
           ssh_result = self.rpc.call_node_ssh_key_remove(
@@ -885,16 +888,8 @@ class LUNodeSetParams(LogicalUnit):
           WarnAboutFailedSshUpdates(ssh_result, master_node, feedback_fn)
 
         if self.new_role == self._ROLE_CANDIDATE:
-          ssh_result = self.rpc.call_node_ssh_key_add(
-            [master_node], node.uuid, node.name,
-            potential_master_candidates,
-            True, # add node's key to all node's 'authorized_keys'
-            True, # all nodes are potential master candidates
-            False) # do not update the node's public keys
-          ssh_result[master_node].Raise(
-            "Could not update the SSH setup of node '%s' after promotion"
-            " (UUID: %s)." % (node.name, node.uuid))
-          WarnAboutFailedSshUpdates(ssh_result, master_node, feedback_fn)
+          AddMasterCandidateSshKey(
+              self, master_node, node, potential_master_candidates, feedback_fn)
 
     return result
 
@@ -1570,14 +1565,14 @@ class LUNodeRemove(LogicalUnit):
     assert locking.BGL in self.owned_locks(locking.LEVEL_CLUSTER), \
       "Not owning BGL"
 
+    master_node = self.cfg.GetMasterNode()
+    potential_master_candidates = self.cfg.GetPotentialMasterCandidates()
     if modify_ssh_setup:
       # retrieve the list of potential master candidates before the node is
       # removed
-      potential_master_candidates = self.cfg.GetPotentialMasterCandidates()
       potential_master_candidate = \
         self.op.node_name in potential_master_candidates
       master_candidate_uuids = self.cfg.GetMasterCandidateUuids()
-      master_node = self.cfg.GetMasterNode()
       result = self.rpc.call_node_ssh_key_remove(
         [master_node],
         self.node.uuid, self.op.node_name,
@@ -1593,7 +1588,9 @@ class LUNodeRemove(LogicalUnit):
       WarnAboutFailedSshUpdates(result, master_node, feedback_fn)
 
     # Promote nodes to master candidate as needed
-    AdjustCandidatePool(self, [self.node.uuid])
+    AdjustCandidatePool(
+        self, [self.node.uuid], master_node, potential_master_candidates,
+        feedback_fn, modify_ssh_setup)
     self.context.RemoveNode(self.cfg, self.node)
 
     # Run post hooks on the node before it's removed
diff --git a/lib/metad.py b/lib/metad.py
new file mode 100644 (file)
index 0000000..48f543e
--- /dev/null
@@ -0,0 +1,96 @@
+#
+#
+
+# Copyright (C) 2014 Google Inc.
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright notice,
+# this list of conditions and the following disclaimer.
+#
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+# PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
+# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+
+"""Module for the Metad protocol
+
+"""
+
+import logging
+import random
+import time
+
+from ganeti import constants
+from ganeti import errors
+import ganeti.rpc.client as cl
+from ganeti.rpc.transport import Transport
+from ganeti.rpc import errors
+
+
+# If the metadata daemon is disabled, there is no stub generated for it.
+# So import the module and define the client class only if enabled, otherwise
+# just generate an empty placeholder class.
+if constants.ENABLE_METAD:
+  import ganeti.rpc.stub.metad as stub
+
+  class Client(cl.AbstractStubClient, stub.ClientRpcStub):
+    """High-level Metad client implementation.
+
+    This uses a backing Transport-like class on top of which it
+    implements data serialization/deserialization.
+
+    """
+    def __init__(self, timeouts=None, transport=Transport):
+      """Constructor for the Client class.
+
+      Arguments are the same as for L{AbstractClient}.
+
+      """
+      cl.AbstractStubClient.__init__(self, timeouts, transport)
+      stub.ClientRpcStub.__init__(self)
+
+      retries = 12
+      for try_no in range(0, retries):
+        try:
+          self._InitTransport()
+          return
+        except errors.TimeoutError:
+          logging.debug("Timout trying to connect to MetaD")
+          if try_no == retries - 1:
+            raise
+          logging.debug("Will retry")
+          time.sleep(try_no * 10 + 10 * random.random())
+
+    def _InitTransport(self):
+      """(Re)initialize the transport if needed.
+
+      """
+      if self.transport is None:
+        self.transport = self.transport_class(self._GetAddress(),
+                                              timeouts=self.timeouts,
+                                              allow_non_master=True)
+
+else:
+  class Client(object):
+    """An empty client representation that just throws an exception.
+
+    """
+    def __init__(self, _timeouts=None, _transport=None):
+      raise errors.ProgrammerError("The metadata deamon is disabled, yet"
+                                   " the client has been called")
index 28936e5..77a1cc4 100644 (file)
@@ -157,6 +157,8 @@ MASTER_SOCKET = SOCKET_DIR + "/ganeti-master"
 QUERY_SOCKET = SOCKET_DIR + "/ganeti-query"
 #: WConfD socket
 WCONFD_SOCKET = SOCKET_DIR + "/ganeti-wconfd"
+#: Metad socket
+METAD_SOCKET = SOCKET_DIR + "/ganeti-metad"
 
 LOG_OS_DIR = LOG_DIR + "/os"
 LOG_ES_DIR = LOG_DIR + "/extstorage"
index 65f82ab..b6ef576 100644 (file)
@@ -964,7 +964,7 @@ class GanetiRapiClient(object): # pylint: disable=R0904
                              ("/%s/instances/%s/activate-disks" %
                               (GANETI_RAPI_VERSION, instance)), query, None)
 
-  def DeactivateInstanceDisks(self, instance, reason=None):
+  def DeactivateInstanceDisks(self, instance, reason=None, force=False):
     """Deactivates an instance's disks.
 
     @type instance: string
@@ -976,6 +976,7 @@ class GanetiRapiClient(object): # pylint: disable=R0904
 
     """
     query = []
+    _AppendForceIf(query, force)
     _AppendReason(query, reason)
     return self._SendRequest(HTTP_PUT,
                              ("/%s/instances/%s/deactivate-disks" %
index 8fee8fb..34b4124 100644 (file)
@@ -1395,6 +1395,7 @@ class R_2_instances_name_deactivate_disks(baserlib.OpcodeResource):
     """
     return ({}, {
       "instance_name": self.items[0],
+      "force": self.useForce(),
       })
 
 
index d7b70b5..e071b79 100644 (file)
@@ -1,7 +1,7 @@
 #
 #
 
-# Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2013 Google Inc.
+# Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Google Inc.
 # All rights reserved.
 #
 # Redistribution and use in source and binary forms, with or without
@@ -59,11 +59,11 @@ from ganeti.utils import version
 #: Target major version we will upgrade to
 TARGET_MAJOR = 2
 #: Target minor version we will upgrade to
-TARGET_MINOR = 14
+TARGET_MINOR = 15
 #: Target major version for downgrade
 DOWNGRADE_MAJOR = 2
 #: Target minor version for downgrade
-DOWNGRADE_MINOR = 13
+DOWNGRADE_MINOR = 14
 
 # map of legacy device types
 # (mapping differing old LD_* constants to new DT_* constants)
@@ -183,8 +183,8 @@ class CfgUpgrade(object):
       self._Downgrade(config_major, config_minor, config_version,
                       config_revision)
 
-    # Upgrade from 2.{0..13} to 2.14
-    elif config_major == 2 and config_minor in range(0, 14):
+    # Upgrade from 2.{0..14} to 2.15
+    elif config_major == 2 and config_minor in range(0, 15):
       if config_revision != 0:
         logging.warning("Config revision is %s, not 0", config_revision)
       if not self.UpgradeAll():
@@ -701,77 +701,19 @@ class CfgUpgrade(object):
 
   # DOWNGRADE ------------------------------------------------------------
 
-  def _RecursiveRemoveNodes(self, disk):
-    if "nodes" in disk:
-      del disk["nodes"]
-    for disk in disk.get("children", []):
-      self._RecursiveRemoveNodes(disk)
-
-  @OrFail("Downgrading disk nodes")
-  def DowngradeDiskNodes(self):
-    if "disks" not in self.config_data:
-      raise Error("Can't find the 'disks' dictionary in the configuration.")
-    for disk in self.config_data["disks"].itervalues():
-      self._RecursiveRemoveNodes(disk)
-
-  @OrFail("Removing forthcoming instances")
-  def DowngradeForthcomingInstances(self):
-    if "instances" not in self.config_data:
-      raise Error("Can't find the 'instances' dictionary in the configuration.")
-    instances = self.config_data["instances"]
-    uuids = instances.keys()
-    for uuid in uuids:
-      if instances[uuid].get("forthcoming"):
-        del instances[uuid]
+  @classmethod
+  def DowngradeCollectors(cls, collectors):
+    if constants.DATA_COLLECTOR_XEN_CPU_LOAD in collectors:
+      del collectors[constants.DATA_COLLECTOR_XEN_CPU_LOAD]
 
-  @OrFail("Removing forthcoming disks")
-  def DowngradeForthcomingDisks(self):
-    if "instances" not in self.config_data:
-      raise Error("Can't find the 'instances' dictionary in the configuration.")
-    instances = self.config_data["instances"]
-    if "disks" not in self.config_data:
-      raise Error("Can't find the 'disks' dictionary in the configuration.")
-    disks = self.config_data["disks"]
-    uuids = disks.keys()
-    for uuid in uuids:
-      if disks[uuid].get("forthcoming"):
-        del disks[uuid]
-        for inst in instances:
-          if "disk" in inst and uuid in inst["disks"]:
-            inst["disks"].remove(uuid)
-
-  @OrFail("Re-adding disk template")
-  def DowngradeDiskTemplate(self):
-    if "instances" not in self.config_data:
-      raise Error("Can't find the 'instances' dictionary in the configuration.")
-    instances = self.config_data["instances"]
-    if "disks" not in self.config_data:
-      raise Error("Can't find the 'disks' dictionary in the configuration.")
-    disks = self.config_data["disks"]
-    for inst in instances.values():
-      instance_disks = [disks.get(uuid) for uuid in inst["disks"]]
-      if any(d is None for d in instance_disks):
-        raise Error("Can't find all disks of instance %s in the configuration."
-                    % inst.name)
-      dev_types = set(d["dev_type"] for d in instance_disks)
-      if len(dev_types) > 1:
-        raise Error("Instance %s has mixed disk types: %s" %
-                    (inst.name, ', '.join(dev_types)))
-      elif len(dev_types) < 1:
-        inst["disk_template"] = constants.DT_DISKLESS
-      else:
-        inst["disk_template"] = dev_types.pop()
+  def DowngradeCluster(self, cluster):
+    self.DowngradeCollectors(cluster["data_collectors"])
 
   def DowngradeAll(self):
+    self.DowngradeCluster(self.config_data["cluster"])
     self.config_data["version"] = version.BuildVersion(DOWNGRADE_MAJOR,
                                                        DOWNGRADE_MINOR, 0)
-    steps = [self.DowngradeForthcomingInstances,
-             self.DowngradeForthcomingDisks,
-             self.DowngradeDiskNodes,
-             self.DowngradeDiskTemplate]
-    for s in steps:
-      s()
-    return not self.errors
+    return True
 
   def _ComposePaths(self):
     # We need to keep filenames locally because they might be renamed between
index ae8fc63..6614c12 100644 (file)
@@ -128,6 +128,16 @@ the entire list of fields.
 Use ``--interval`` to repeat the listing. A delay specified by the
 option value in seconds is inserted.
 
+METAD
+~~~~~
+
+| **metad** echo *text*
+
+Tests the WConf daemon by invoking its ``echo`` function.
+
+A given text is sent to Metad through RPC, echoed back by Metad and
+printed to the console.
+
 WCONFD
 ~~~~~~
 
index e11442a..67408db 100644 (file)
@@ -34,7 +34,9 @@ the CPUload collector.
 ALGORITHM
 ~~~~~~~~~
 
-The program uses a simplified version of the hbal algorithm.
+On regular node groups, the program uses a simplified version of
+the hbal algorithm; for allocation on node groups with exclusive
+storage see below.
 
 For single-node allocations (non-mirrored instances), again we
 select the node which, when chosen as the primary node, gives the best
@@ -64,6 +66,17 @@ The deprecated *multi-evacuate* modes is no longer supported.
 In all cases, the cluster (or group) scoring is identical to the hbal
 algorithm.
 
+For allocation on node groups with exclusive storage, the lost-allocations
+metrics is used instead to determine which node to allocate an instance
+on. For a node the allocation vector is the vector of, for each instance
+policy interval in decreasing order, the number of instances minimally
+compliant with that interval that still can be placed on that node. The
+lost-allocations vector for an instance on a node is the difference of
+the allocation vectors for that node before and after placing the
+instance on that node. The lost-allocations metrics is the lost allocation
+vector followed by the remaining disk space on the chosen node, all
+compared lexicographically.
+
 OPTIONS
 -------
 
index 8043a46..8cc4a72 100644 (file)
@@ -33,6 +33,8 @@ Algorithm options:
 **[ \--ignore-dynu ]**
 **[ \--ignore-soft-errors ]**
 **[ \--mond *yes|no* ]**
+**[ \--mond-xen ]**
+**[ \--exit-on-missing-mond-data ]**
 **[ \--evac-mode ]**
 **[ \--restricted-migration ]**
 **[ \--select-instances *inst...* ]**
@@ -116,6 +118,7 @@ following components:
 
 - standard deviation of the percent of free memory
 - standard deviation of the percent of reserved memory
+- the sum of the percentages of reserved memory
 - standard deviation of the percent of free disk
 - count of nodes failing N+1 check
 - count of instances living (either as primary or secondary) on
@@ -184,7 +187,8 @@ nodes with less CPU load.
 
 On a perfectly balanced cluster (all nodes the same size, all
 instances the same size and spread across the nodes equally), the
-values for all metrics would be zero. This doesn't happen too often in
+values for all metrics would be zero, with the exception of the total
+percentage of reserved memory. This doesn't happen too often in
 practice :)
 
 OFFLINE INSTANCES
@@ -307,8 +311,8 @@ The options that can be passed to the program are as follows:
   any numeric fields.
 
 -e *score*, \--min-score=*score*
-  This parameter denotes the minimum score we are happy with and alters
-  the computation in two ways:
+  This parameter denotes how much above the N+1 bound the cluster score
+  can for us to be happy with and alters the computation in two ways:
 
   - if the cluster has the initial score lower than this value, then we
     don't enter the algorithm at all, and exit with success
@@ -420,6 +424,15 @@ The options that can be passed to the program are as follows:
   If given the program will query all MonDs to fetch data from the
   supported data collectors over the network.
 
+\--mond-xen
+  If given, also query Xen-specific collectors from MonD, provided
+  that monitoring daemons are queried at all.
+
+\--exit-on-missing-mond-data
+  If given, abort if the data obtainable from querying MonDs is incomplete.
+  The default behavior is to continue with a best guess based on the static
+  information.
+
 \--mond-data *datafile*
   The name of the file holding the data provided by MonD, to override
   quering MonDs over the network. This is mostly used for debugging. The
index 6db02b9..c64230c 100644 (file)
@@ -31,10 +31,12 @@ Algorithm options:
 **[ \--no-disk-moves ]**
 **[ \--no-instance-moves ]**
 **[ -U *util-file* ]**
+**[ \--ignore-dynu ]**
 **[ \--ignore-soft-errors ]**
 **[ \--evac-mode ]**
 **[ \--select-instances *inst...* ]**
 **[ \--exclude-instances *inst...* ]**
+**[ \--no-capacity-checks ]**
 
 Reporting options:
 
@@ -58,6 +60,11 @@ simulation if necessary.
 
 For more information about the algorithm details check **hbal**\(1).
 
+Additionally, hcheck also checks if the cluster is globally N+1 redundant.
+That is, it checks for every node, if after failing over the DRBD instances
+all instances on that node that with disks externally stored can be restarted
+on some other node.
+
 OPTIONS
 -------
 
@@ -65,6 +72,11 @@ OPTIONS
   Only perform checks based on current cluster state, without trying
   to simulate rebalancing.
 
+\--no-capacity-checks
+  Do not check for global N+1 redundancy, i.e., do not warn if the
+  shared-storage instances of one node cannot be moved to the others
+  should that node fail.
+
 For a detailed description about the options listed above have a look at
 **htools**\(1), **hspace**\(1) and **hbal**\(1).
 
index a4f887e..ac1d3a8 100644 (file)
@@ -32,6 +32,7 @@
 
 """
 
+import os
 import re
 import tempfile
 import time
@@ -1307,7 +1308,9 @@ def TestClusterBurnin():
     if len(instances) < 1:
       raise qa_error.Error("Burnin needs at least one instance")
 
-    script = qa_utils.UploadFile(master.primary, "../tools/burnin")
+    burnin_file = os.path.join(os.path.dirname(os.path.realpath(__file__)),
+                               "../tools/burnin")
+    script = qa_utils.UploadFile(master.primary, burnin_file)
     try:
       disks = qa_config.GetDiskOptions()
       # Run burnin
index 276b92c..f84daf8 100644 (file)
@@ -497,6 +497,17 @@ class _QaConfig(object):
     """
     return self["nodes"][0]
 
+  def GetAllNodes(self):
+    """Returns the list of nodes.
+
+    This is not intended to 'acquire' those nodes. For that,
+    C{AcquireManyNodes} is better suited. However, often it is
+    helpful to know the total number of nodes available to
+    adjust cluster parameters and that's where this function
+    is useful.
+    """
+    return self["nodes"]
+
   def GetInstanceCheckScript(self):
     """Returns path to instance check script or C{None}.
 
@@ -851,6 +862,13 @@ def GetMasterNode():
   return GetConfig().GetMasterNode()
 
 
+def GetAllNodes():
+  """Wrapper for L{_QaConfig.GetAllNodes}.
+
+  """
+  return GetConfig().GetAllNodes()
+
+
 def AcquireInstance(_cfg=None):
   """Returns an instance which isn't in use.
 
index b752932..d1d1403 100644 (file)
@@ -252,6 +252,16 @@ def TestNodeEvacuate(node, node2):
 def TestNodeModify(node):
   """gnt-node modify"""
 
+  default_pool_size = 10
+  nodes = qa_config.GetAllNodes()
+  test_pool_size = len(nodes) - 1
+
+  # Reduce the number of master candidates, because otherwise all
+  # subsequent 'gnt-cluster verify' commands fail due to not enough
+  # master candidates.
+  AssertCommand(["gnt-cluster", "modify",
+                 "--candidate-pool-size=%s" % test_pool_size])
+
   # make sure enough master candidates will be available by disabling the
   # master candidate role first with --auto-promote
   AssertCommand(["gnt-node", "modify", "--master-candidate=no",
@@ -262,6 +272,7 @@ def TestNodeModify(node):
     for value in ["yes", "no"]:
       AssertCommand(["gnt-node", "modify", "--force",
                      "--%s=%s" % (flag, value), node.primary])
+      AssertCommand(["gnt-cluster", "verify"])
 
   AssertCommand(["gnt-node", "modify", "--master-candidate=yes", node.primary])
 
@@ -270,6 +281,8 @@ def TestNodeModify(node):
                  node.primary])
 
   AssertRedirectedCommand(["gnt-cluster", "verify"])
+  AssertCommand(["gnt-cluster", "modify",
+                 "--candidate-pool-size=%s" % default_pool_size])
 
 
 def _CreateOobScriptStructure():
index f416afe..3213669 100644 (file)
@@ -72,7 +72,7 @@ getDisks
   -> BT.ResultT String IO [Ganeti.Objects.Disk]
 getDisks inst srvAddr srvPort = do
   client <- liftIO $ getConfdClient srvAddr srvPort
-  reply <- liftIO . query client ReqInstanceDisks . PlainQuery . instUuid $ inst
+  reply <- liftIO . query client ReqInstanceDisks . PlainQuery . uuidOf $ inst
   case fmap (J.readJSON . confdReplyAnswer) reply of
     Just (J.Ok disks) -> return disks
     Just (J.Error msg) -> fail msg
index 7556527..774054b 100644 (file)
@@ -222,7 +222,7 @@ buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeDrbd }) = do
                  PlainQuery str -> return str
                  _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
   node <- gntErrorToResult $ getNode cfg node_name
-  let minors = concatMap (getInstMinorsForNode cfg (nodeUuid node)) .
+  let minors = concatMap (getInstMinorsForNode cfg (uuidOf node)) .
                M.elems . fromContainer . configInstances $ cfg
   encoded <- mapM (encodeMinors cfg) minors
   return (ReplyStatusOk, J.showJSON encoded, nodeSerial node)
@@ -238,7 +238,7 @@ buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeInstances }) = do
     case getNode cfg node_name of
       Ok n -> return n
       Bad e -> fail $ "Node not found in the configuration: " ++ show e
-  let node_uuid = nodeUuid node
+  let node_uuid = uuidOf node
       instances = getNodeInstances cfg node_uuid
   return (ReplyStatusOk, J.showJSON instances, nodeSerial node)
 
@@ -253,7 +253,7 @@ buildResponse cdata req@(ConfdRequest { confdRqType = ReqInstanceDisks }) = do
     case getInstance cfg inst_name of
       Ok i -> return i
       Bad e -> fail $ "Instance not found in the configuration: " ++ show e
-  case getInstDisks cfg . instUuid $ inst of
+  case getInstDisks cfg . uuidOf $ inst of
     Ok disks -> return (ReplyStatusOk, J.showJSON disks, instSerial inst)
     Bad e -> fail $ "Could not retrieve disks: " ++ show e
 
index ddbb7b1..264aae0 100644 (file)
@@ -175,7 +175,7 @@ getNodeInstances cfg nname =
 -- | Computes the role of a node.
 getNodeRole :: ConfigData -> Node -> NodeRole
 getNodeRole cfg node
-  | nodeUuid node == clusterMasterNode (configCluster cfg) = NRMaster
+  | uuidOf node == clusterMasterNode (configCluster cfg) = NRMaster
   | nodeMasterCandidate node = NRCandidate
   | nodeDrained node = NRDrained
   | nodeOffline node = NROffline
@@ -322,7 +322,7 @@ getGroupNodes cfg gname =
 -- | Get (primary, secondary) instances of a given node group.
 getGroupInstances :: ConfigData -> String -> ([Instance], [Instance])
 getGroupInstances cfg gname =
-  let gnodes = map nodeUuid (getGroupNodes cfg gname)
+  let gnodes = map uuidOf (getGroupNodes cfg gname)
       ginsts = map (getNodeInstances cfg) gnodes in
   (concatMap fst ginsts, concatMap snd ginsts)
 
@@ -409,7 +409,7 @@ getInstDisks cfg iname =
 -- | Get disks for a given instance object.
 getInstDisksFromObj :: ConfigData -> Instance -> ErrorResult [Disk]
 getInstDisksFromObj cfg =
-  getInstDisks cfg . instUuid
+  getInstDisks cfg . uuidOf
 
 -- | Collects a value for all DRBD disks
 collectFromDrbdDisks
@@ -496,7 +496,7 @@ buildLinkIpInstnameMap cfg =
   let cluster = configCluster cfg
       instances = M.elems . fromContainer . configInstances $ cfg
       defparams = (M.!) (fromContainer $ clusterNicparams cluster) C.ppDefault
-      nics = concatMap (\i -> [(fromMaybe (instUuid i) $ instName i, nic)
+      nics = concatMap (\i -> [(fromMaybe (uuidOf i) $ instName i, nic)
                                 | nic <- instNics i])
              instances
   in foldl' (\accum (iname, nic) ->
index 7e960af..6452962 100644 (file)
@@ -4828,6 +4828,16 @@ cpuavgloadBufferSize = 150
 cpuavgloadWindowSize :: Int
 cpuavgloadWindowSize = 600
 
+-- * Xen cpu load collector
+
+xentopCommand :: String
+xentopCommand = "xentop"
+
+-- | Minimal observation time in seconds, the xen cpu load collector
+-- can report load averages for the first time.
+xentopAverageThreshold :: Int
+xentopAverageThreshold = 100
+
 -- * Monitoring daemon
 
 -- | Mond's variable for periodical data collection
@@ -5317,6 +5327,9 @@ ipv4NetworkMaxSize = 30
 dataCollectorCPULoad    :: String
 dataCollectorCPULoad    = "cpu-avg-load"
 
+dataCollectorXenCpuLoad :: String
+dataCollectorXenCpuLoad = "xen-cpu-avg-load"
+
 dataCollectorDiskStats  :: String
 dataCollectorDiskStats  = "diskstats"
 
@@ -5339,6 +5352,7 @@ dataCollectorNames =
                       , dataCollectorDrbd
                       , dataCollectorLv
                       , dataCollectorInstStatus
+                      , dataCollectorXenCpuLoad
                       ]
 
 dataCollectorStateActive :: String
index 2478f5a..0a7cf61 100644 (file)
@@ -515,7 +515,9 @@ innerMain daemon opts syslog check_result prep_fn exec_fn fd = do
                  `Control.Exception.catch` handlePrepErr True fd
   -- no error reported, we should now close the fd
   maybeCloseFd fd
-  finally (exec_fn opts check_result prep_result) (finalCleanup pidFile)
+  finally (exec_fn opts check_result prep_result)
+          (finalCleanup pidFile
+           >> logNotice (daemonName daemon ++ " daemon shutdown"))
 
 -- | Daemon prepare error handling function.
 handlePrepErr :: Bool -> Maybe Fd -> IOError -> IO a
index 70d6207..bca6848 100644 (file)
@@ -42,6 +42,7 @@ import qualified Ganeti.DataCollectors.Diskstats as Diskstats
 import qualified Ganeti.DataCollectors.Drbd as Drbd
 import qualified Ganeti.DataCollectors.InstStatus as InstStatus
 import qualified Ganeti.DataCollectors.Lv as Lv
+import qualified Ganeti.DataCollectors.XenCpuLoad as XenCpuLoad
 import Ganeti.DataCollectors.Types (DataCollector(..),ReportBuilder(..))
 import Ganeti.JSON (GenericContainer(..))
 import Ganeti.Objects
@@ -51,6 +52,7 @@ import Ganeti.Types
 collectors :: [DataCollector]
 collectors =
   [ cpuLoadCollector
+  , xenCpuLoadCollector
   , diskStatsCollector
   , drdbCollector
   , instStatusCollector
@@ -84,3 +86,7 @@ collectors =
       DataCollector CPUload.dcName CPUload.dcCategory CPUload.dcKind
         (StatefulR CPUload.dcReport) (Just CPUload.dcUpdate) activeConfig
         updateInterval
+    xenCpuLoadCollector =
+      DataCollector XenCpuLoad.dcName XenCpuLoad.dcCategory XenCpuLoad.dcKind
+        (StatefulR XenCpuLoad.dcReport) (Just XenCpuLoad.dcUpdate) activeConfig
+        updateInterval
index 578819b..1e7f3a8 100644 (file)
@@ -46,6 +46,7 @@ module Ganeti.DataCollectors.InstStatus
 
 
 import Control.Exception.Base
+import qualified Data.ByteString.UTF8 as UTF8
 import Data.List
 import Data.Maybe
 import qualified Data.Map as Map
@@ -167,7 +168,7 @@ buildStatus domains uptimes inst = do
   return $
     InstStatus
       name
-      (realInstUuid inst)
+      (UTF8.toString $ realInstUuid inst)
       adminState
       actualState
       uptime
index 9170ad9..8b60be1 100644 (file)
@@ -144,7 +144,9 @@ instance JSON DCVersion where
   readJSON v = fail $ "Invalid JSON value " ++ show v ++ " for type DCVersion"
 
 -- | Type for the value field of the `CollectorMap` below.
-data CollectorData = CPULoadData (Seq.Seq (ClockTime, [Int]))
+data CollectorData =
+  CPULoadData (Seq.Seq (ClockTime, [Int]))
+  | InstanceCpuLoad (Map.Map String (Seq.Seq (ClockTime, Double)))
 
 instance NFData ClockTime where
   rnf (TOD x y) = rnf x `seq` rnf y
@@ -153,6 +155,7 @@ instance NFData ClockTime where
 
 instance NFData CollectorData where
   rnf (CPULoadData x) = rnf x
+  rnf (InstanceCpuLoad x) = rnf x
 
 #else
 
@@ -166,6 +169,8 @@ form
 
 instance NFData CollectorData where
   rnf (CPULoadData x) =  (x `using` seqFoldable rdeepseq) `seq` ()
+  rnf (InstanceCpuLoad x) = (x `using` seqFoldable (seqFoldable rdeepseq))
+                            `seq` ()
 
 #endif
 
diff --git a/src/Ganeti/DataCollectors/XenCpuLoad.hs b/src/Ganeti/DataCollectors/XenCpuLoad.hs
new file mode 100644 (file)
index 0000000..10c39cd
--- /dev/null
@@ -0,0 +1,173 @@
+{-| xentop CPU data collector
+
+-}
+
+{-
+
+Copyright (C) 2015 Google Inc.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+-}
+
+module Ganeti.DataCollectors.XenCpuLoad
+  ( dcName
+  , dcVersion
+  , dcFormatVersion
+  , dcCategory
+  , dcKind
+  , dcReport
+  , dcUpdate
+  ) where
+
+import Control.Applicative ((<$>), liftA2)
+import Control.Arrow ((***))
+import Control.Monad (liftM, when)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Map as Map
+import Data.Maybe (mapMaybe)
+import qualified Data.Sequence as Seq
+import System.Process (readProcess)
+import qualified Text.JSON as J
+import System.Time (ClockTime, getClockTime, addToClockTime)
+
+import Ganeti.BasicTypes (GenericResult(..), Result, genericResult, runResultT)
+import qualified Ganeti.Constants as C
+import Ganeti.DataCollectors.Types
+import Ganeti.Utils (readMaybe, clockTimeToUSec, diffClockTimes)
+
+-- | The name of this data collector.
+dcName :: String
+dcName = C.dataCollectorXenCpuLoad
+
+-- | The version of this data collector.
+dcVersion :: DCVersion
+dcVersion = DCVerBuiltin
+
+-- | The version number for the data format of this data collector.
+dcFormatVersion :: Int
+dcFormatVersion = 1
+
+-- | The category of this data collector.
+dcCategory :: Maybe DCCategory
+dcCategory = Nothing
+
+-- | The kind of this data collector.
+dcKind :: DCKind
+dcKind = DCKPerf
+
+-- | Read xentop output, if this program is available.
+readXentop :: IO (Result String)
+readXentop =
+  runResultT . liftIO $ readProcess C.xentopCommand ["-f", "-b", "-i", "1"] ""
+
+-- | Parse output of xentop command.
+parseXentop :: String -> Result (Map.Map String Double)
+parseXentop s = do
+  let values = map words $ lines s
+  case values of
+    [] -> Bad "No output received"
+    (name_header:_:cpu_header:_):vals -> do
+      when (name_header /= "NAME" || cpu_header /= "CPU(sec)")
+        $ Bad "Unexpected data format"
+      return . Map.fromList
+        $ mapMaybe
+            (\ dom -> case dom of
+                        name:_:cpu:_ -> if name /= "Domain-0"
+                                          then liftM ((,) name) $ readMaybe cpu
+                                          else Nothing
+                        _ -> Nothing
+            )
+            vals
+    _ -> Bad "Insufficient number of output columns"
+
+
+-- | Add a new value to a sequence of observations, taking into account
+-- counter rollovers. In case of a rollover, we drop the joining interval
+-- so that we do not have to make assumptions about the value at which is
+-- rolled over, but we do keep the right sequence, appropriately moved.
+combineWithRollover :: Seq.Seq (ClockTime, Double)
+                    -> Seq.Seq (ClockTime, Double)
+                    -> Seq.Seq (ClockTime, Double)
+combineWithRollover new old | Seq.null new || Seq.null old = new Seq.>< old
+combineWithRollover new old =
+  let (t2, x2) = Seq.index new $ Seq.length new - 1
+      (t1, x1) = Seq.index old 0
+  in if x2 >= x1
+       then new Seq.>< old
+       else let delta_t = diffClockTimes t2 t1
+                deltax = x2 - x1
+                old' = (addToClockTime delta_t *** (+ deltax))
+                       <$> Seq.drop 1 old
+            in new Seq.>< old'
+
+-- | Updates the given Collector data.
+dcUpdate :: Maybe CollectorData -> IO CollectorData
+dcUpdate maybeCollector = do
+  let oldData = case maybeCollector of
+                  Just (InstanceCpuLoad x) -> x
+                  _ -> Map.empty
+  now <- getClockTime
+  newResult <- liftM (>>= parseXentop) readXentop
+  let newValues = Map.map (Seq.singleton . (,) now)
+                  $ genericResult (const Map.empty) id newResult
+      sampleSizeUSec = fromIntegral C.cpuavgloadWindowSize * 1000000
+      combinedValues = Map.unionWith combineWithRollover newValues oldData
+      withinRange = Map.map
+                      (Seq.dropWhileR
+                        ((<) sampleSizeUSec
+                         . (clockTimeToUSec now -)
+                         . clockTimeToUSec . fst))
+                      combinedValues
+      withoutOld = Map.filter
+                     (liftA2 (&&) (not . Seq.null)
+                      $ (>) (fromIntegral $ C.xentopAverageThreshold * 1000000)
+                        . (clockTimeToUSec now -) . clockTimeToUSec
+                        . fst . flip Seq.index 0)
+                     withinRange
+  return $ InstanceCpuLoad withoutOld
+
+-- | From a list of timestamps and cumulative CPU data, compute the
+-- average CPU activity in vCPUs.
+loadAverage :: Seq.Seq (ClockTime, Double) -> Maybe Double
+loadAverage observations = do
+  when (Seq.null observations) Nothing
+  let (t2, cpu2) = Seq.index observations 0
+      (t1, cpu1) = Seq.index observations $ Seq.length observations - 1
+      tUsec2 = clockTimeToUSec t2
+      tUsec1 = clockTimeToUSec t1
+  when (tUsec2 - tUsec1 < (fromIntegral C.xentopAverageThreshold * 1000000))
+    Nothing
+  return $ 1000000 * (cpu2 - cpu1) / fromIntegral (tUsec2 - tUsec1)
+
+-- | The data exported by the data collector, taken from the default location.
+dcReport :: Maybe CollectorData -> IO DCReport
+dcReport maybeCollector =
+  let collectedData = case maybeCollector of
+                        Just (InstanceCpuLoad x) -> x
+                        _ -> Map.empty
+      loads = Map.mapMaybe loadAverage collectedData
+  in buildReport dcName dcVersion dcFormatVersion dcCategory dcKind
+      . J.JSObject . J.toJSObject . Map.toAscList $ Map.map J.showJSON loads
index c4a8459..531c238 100644 (file)
@@ -37,6 +37,9 @@ module Ganeti.HTools.Backend.IAlloc
   , runIAllocator
   , processRelocate
   , loadData
+  , formatAllocate
+  , formatIAllocResult
+  , formatMultiAlloc
   ) where
 
 import Data.Either ()
@@ -49,6 +52,7 @@ import Text.JSON (JSObject, JSValue(JSArray),
 
 import Ganeti.BasicTypes
 import qualified Ganeti.HTools.Cluster as Cluster
+import qualified Ganeti.HTools.Cluster.Evacuate as Evacuate
 import qualified Ganeti.HTools.Container as Container
 import qualified Ganeti.HTools.Group as Group
 import qualified Ganeti.HTools.Node as Node
@@ -294,11 +298,13 @@ formatResponse success info result =
   in encodeStrict $ makeObj [e_success, e_info, e_result]
 
 -- | Flatten the log of a solution into a string.
-describeSolution :: Cluster.AllocSolution -> String
+describeSolution :: Cluster.GenericAllocSolution a -> String
 describeSolution = intercalate ", " . Cluster.asLog
 
 -- | Convert allocation/relocation results into the result format.
-formatAllocate :: Instance.List -> Cluster.AllocSolution -> Result IAllocResult
+formatAllocate :: Instance.List
+               -> Cluster.GenericAllocSolution a
+               -> Result IAllocResult
 formatAllocate il as = do
   let info = describeSolution as
   case Cluster.asSolution as of
@@ -309,7 +315,8 @@ formatAllocate il as = do
         return (info, showJSON $ map Node.name nodes, nl, il')
 
 -- | Convert multi allocation results into the result format.
-formatMultiAlloc :: (Node.List, Instance.List, Cluster.AllocSolutionList)
+formatMultiAlloc :: ( Node.List, Instance.List
+                    , Cluster.GenericAllocSolutionList a)
                  -> Result IAllocResult
 formatMultiAlloc (fin_nl, fin_il, ars) =
   let rars = reverse ars
@@ -330,20 +337,20 @@ formatMultiAlloc (fin_nl, fin_il, ars) =
 formatNodeEvac :: Group.List
                -> Node.List
                -> Instance.List
-               -> (Node.List, Instance.List, Cluster.EvacSolution)
+               -> (Node.List, Instance.List, Evacuate.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
+      fes = map (\(idx, msg) -> (iname idx, msg)) $ Evacuate.esFailed es
       mes = map (\(idx, gdx, ndxs) -> (iname idx, gname gdx, map nname ndxs))
-            $ Cluster.esMoved es
+            $ Evacuate.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)
+  in Ok (info, showJSON (mes, fes, Evacuate.esOpCodes es), fin_nl, fin_il)
 
 -- | Runs relocate for a single instance.
 --
@@ -376,12 +383,12 @@ processRelocate opts gl nl il idx 1 exndx = do
        fail $ "Unsupported request: excluded nodes not equal to\
               \ instance's " ++  node_type ++ "(" ++ show exp_node
               ++ " versus " ++ show exndx ++ ")"
-  (nl', il', esol) <- Cluster.tryNodeEvac opts gl nl il reloc_type [idx]
-  nodes <- case lookup idx (Cluster.esFailed esol) of
+  (nl', il', esol) <- Evacuate.tryNodeEvac opts gl nl il reloc_type [idx]
+  nodes <- case lookup idx (Evacuate.esFailed esol) of
              Just msg -> fail msg
              Nothing ->
                  case lookup idx (map (\(a, _, b) -> (a, b))
-                                  (Cluster.esMoved esol)) of
+                                  (Evacuate.esMoved esol)) of
                    Nothing ->
                        fail "Internal error: lost instance idx during move"
                    Just n -> return n
@@ -437,7 +444,7 @@ processRequest opts request =
          Cluster.tryChangeGroup opts gl nl il idxs gdxs >>=
                 formatNodeEvac gl nl il
        NodeEvacuate xi mode ->
-         Cluster.tryNodeEvac opts gl nl il mode xi >>=
+         Evacuate.tryNodeEvac opts gl nl il mode xi >>=
                 formatNodeEvac gl nl il
        MultiAllocate xies ->
          Cluster.allocList opts gl nl il xies [] >>= formatMultiAlloc
@@ -453,18 +460,23 @@ readRequest fp = do
     Bad err -> exitErr err
     Ok (fix_msgs, rq) -> maybeShowWarnings fix_msgs >> return rq
 
--- | Main iallocator pipeline.
-runIAllocator :: AlgorithmOptions
-              -> Request -> (Maybe (Node.List, Instance.List), String)
-runIAllocator opts request =
+-- | Format an IAlloc result to maybe the new cluster and a response.
+formatIAllocResult :: Result IAllocResult
+                   -> (Maybe (Node.List, Instance.List), String)
+formatIAllocResult iallocResult =
   let (ok, info, result, cdata) =
-        case processRequest opts request of
+        case iallocResult of
           Ok (msg, r, nl, il) -> (True, "Request successful: " ++ msg, r,
                                   Just (nl, il))
           Bad msg -> (False, "Request failed: " ++ msg, JSArray [], Nothing)
       rstring = formatResponse ok info result
   in (cdata, rstring)
 
+-- | Main iallocator pipeline.
+runIAllocator :: AlgorithmOptions
+              -> Request -> (Maybe (Node.List, Instance.List), String)
+runIAllocator opts request = formatIAllocResult $ processRequest opts request
+
 -- | Load the data from an iallocation request file
 loadData :: FilePath -- ^ The path to the file
          -> IO (Result ClusterData)
diff --git a/src/Ganeti/HTools/Backend/MonD.hs b/src/Ganeti/HTools/Backend/MonD.hs
new file mode 100644 (file)
index 0000000..744d52d
--- /dev/null
@@ -0,0 +1,306 @@
+{-# LANGUAGE BangPatterns #-}
+
+{-| Monitoring daemon backend
+
+This module holds implements the querying of the monitoring daemons
+for dynamic utilisation data.
+
+-}
+
+{-
+
+Copyright (C) 2015 Google Inc.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+-}
+
+
+module Ganeti.HTools.Backend.MonD
+  ( queryAllMonDDCs
+  , pMonDData
+  ) where
+
+import Control.Monad
+import Control.Monad.Writer
+import qualified Data.List as L
+import qualified Data.IntMap as IntMap
+import qualified Data.Map as Map
+import Data.Maybe (catMaybes, mapMaybe)
+import qualified Data.Set as Set
+import Network.Curl
+import qualified Text.JSON as J
+
+import Ganeti.BasicTypes
+import qualified Ganeti.Constants as C
+import Ganeti.Cpu.Types
+import qualified Ganeti.DataCollectors.XenCpuLoad as XenCpuLoad
+import qualified Ganeti.DataCollectors.CPUload as CPUload
+import Ganeti.DataCollectors.Types ( DCReport, DCCategory
+                                   , dcReportData, dcReportName
+                                   , getCategoryName )
+import qualified Ganeti.HTools.Container as Container
+import qualified Ganeti.HTools.Node as Node
+import qualified Ganeti.HTools.Instance as Instance
+import Ganeti.HTools.Loader (ClusterData(..))
+import Ganeti.HTools.Types
+import Ganeti.HTools.CLI
+import Ganeti.JSON
+import Ganeti.Logging.Lifted (logWarning)
+import Ganeti.Utils (exitIfBad)
+
+-- * General definitions
+
+-- | The actual data types for MonD's Data Collectors.
+data Report = CPUavgloadReport CPUavgload
+            | InstanceCpuReport (Map.Map String Double)
+
+-- | Type describing a data collector basic information.
+data DataCollector = DataCollector
+  { dName     :: String           -- ^ Name of the data collector
+  , dCategory :: Maybe DCCategory -- ^ The name of the category
+  , dMkReport :: DCReport -> Maybe Report -- ^ How to parse a monitor report
+  , dUse      :: [(Node.Node, Report)]
+                 -> (Node.List, Instance.List)
+                 -> Result (Node.List, Instance.List)
+                 -- ^ How the collector reports are to be used to bring dynamic
+                 -- data into a cluster
+  }
+
+-- * Node-total CPU load average data collector
+
+-- | Parse a DCReport for the node-total CPU collector.
+mkCpuReport :: DCReport -> Maybe Report
+mkCpuReport dcr =
+  case fromJVal (dcReportData dcr) :: Result CPUavgload of
+    Ok cav -> Just $ CPUavgloadReport cav
+    Bad _ -> Nothing
+
+-- | Take reports of node CPU values and update a node accordingly.
+updateNodeCpuFromReport :: (Node.Node, Report) -> Node.Node
+updateNodeCpuFromReport (node, CPUavgloadReport cav) =
+  let ct = cavCpuTotal cav
+      du = Node.utilLoad node
+      du' = du {cpuWeight = ct}
+  in node { Node.utilLoad = du' }
+updateNodeCpuFromReport (node, _) = node
+
+-- | Update the instance CPU-utilization data, asuming that each virtual
+-- CPU contributes equally to the node CPU load.
+updateCpuUtilDataFromNode :: Instance.List -> Node.Node -> Instance.List
+updateCpuUtilDataFromNode il node =
+  let ct = cpuWeight (Node.utilLoad node)
+      n_uCpu = Node.uCpu node
+      upd inst =
+        if Node.idx node == Instance.pNode inst
+          then
+            let i_vcpus = Instance.vcpus inst
+                i_util = ct / fromIntegral n_uCpu * fromIntegral i_vcpus
+                i_du = Instance.util inst
+                i_du' = i_du {cpuWeight = i_util}
+            in inst {Instance.util = i_du'}
+          else inst
+  in Container.map upd il
+
+-- | Update cluster data from node CPU load reports.
+useNodeTotalCPU :: [(Node.Node, Report)]
+                -> (Node.List, Instance.List)
+                -> Result (Node.List, Instance.List)
+useNodeTotalCPU reports (nl, il) =
+  let newnodes = map updateNodeCpuFromReport reports
+      il' = foldl updateCpuUtilDataFromNode il newnodes
+      nl' = zip (Container.keys nl) newnodes
+  in return (Container.fromList nl', il')
+
+-- | The node-total CPU collector.
+totalCPUCollector :: DataCollector
+totalCPUCollector = DataCollector { dName = CPUload.dcName
+                                  , dCategory = CPUload.dcCategory
+                                  , dMkReport = mkCpuReport
+                                  , dUse = useNodeTotalCPU
+                                  }
+
+-- * Xen instance CPU-usage collector
+
+-- | Parse results of the Xen-Cpu-load data collector.
+mkXenCpuReport :: DCReport -> Maybe Report
+mkXenCpuReport =
+  liftM InstanceCpuReport . maybeParseMap . dcReportData
+
+-- | Update cluster data based on the per-instance CPU usage
+-- reports
+useInstanceCpuData :: [(Node.Node, Report)]
+                   -> (Node.List, Instance.List)
+                   -> Result (Node.List, Instance.List)
+useInstanceCpuData reports (nl, il) = do
+  let toMap (InstanceCpuReport m) = Just m
+      toMap _ = Nothing
+  let usage = Map.unions $ mapMaybe (toMap . snd) reports
+      missingData = (Set.fromList . map Instance.name $ IntMap.elems il)
+                    Set.\\ Map.keysSet usage
+  unless (Set.null missingData)
+    . Bad . (++) "No CPU information available for "
+    . show $ Set.elems missingData
+  let updateInstance inst =
+        let cpu = Map.lookup (Instance.name inst) usage
+            dynU = Instance.util inst
+            dynU' = maybe dynU (\c -> dynU { cpuWeight = c }) cpu
+        in inst { Instance.util = dynU' }
+  let il' = IntMap.map updateInstance il
+  let updateNode node =
+        let cpu = sum
+                  . map (\ idx -> maybe 0 (cpuWeight . Instance.util)
+                                  $ IntMap.lookup idx il')
+                  $ Node.pList node
+            dynU = Node.utilLoad node
+            dynU' = dynU { cpuWeight = cpu }
+        in node { Node.utilLoad = dynU' }
+  let nl' = IntMap.map updateNode nl
+  return (nl', il')
+
+-- | Collector for per-instance CPU data as observed by Xen
+xenCPUCollector :: DataCollector
+xenCPUCollector = DataCollector { dName = XenCpuLoad.dcName
+                                , dCategory = XenCpuLoad.dcCategory
+                                , dMkReport = mkXenCpuReport
+                                , dUse = useInstanceCpuData
+                                }
+
+-- * Collector choice
+
+-- | The list of Data Collectors used by hail and hbal.
+collectors :: Options -> [DataCollector]
+collectors opts
+  | optIgnoreDynu opts = []
+  | optMonDXen opts = [ xenCPUCollector ]
+  | otherwise = [ totalCPUCollector ]
+
+-- * Querying infrastructure
+
+-- | Return the data from correct combination of a Data Collector
+-- and a DCReport.
+mkReport :: DataCollector -> Maybe DCReport -> Maybe Report
+mkReport dc = (>>= dMkReport dc)
+
+-- | MonDs Data parsed by a mock file. Representing (node name, list of reports
+-- produced by MonDs Data Collectors).
+type MonDData = (String, [DCReport])
+
+-- | A map storing MonDs data.
+type MapMonDData = Map.Map String [DCReport]
+
+-- | Get data report for the specified Data Collector and Node from the map.
+fromFile :: DataCollector -> Node.Node -> MapMonDData -> Maybe DCReport
+fromFile dc node m =
+  let matchDCName dcr = dName dc == dcReportName dcr
+  in maybe Nothing (L.find matchDCName) $ Map.lookup (Node.name node) m
+
+-- | Get Category Name.
+getDCCName :: Maybe DCCategory -> String
+getDCCName dcc =
+  case dcc of
+    Nothing -> "default"
+    Just c -> getCategoryName c
+
+-- | Prepare url to query a single collector.
+prepareUrl :: DataCollector -> Node.Node -> URLString
+prepareUrl dc node =
+  Node.name node ++ ":" ++ show C.defaultMondPort ++ "/"
+  ++ show C.mondLatestApiVersion ++ "/report/" ++
+  getDCCName (dCategory dc) ++ "/" ++ dName dc
+
+-- | Query a specified MonD for a Data Collector.
+fromCurl :: DataCollector -> Node.Node -> IO (Maybe DCReport)
+fromCurl dc node = do
+  (code, !body) <-  curlGetString (prepareUrl dc node) []
+  case code of
+    CurlOK ->
+      case J.decodeStrict body :: J.Result DCReport of
+        J.Ok r -> return $ Just r
+        J.Error _ -> return Nothing
+    _ -> do
+      logWarning $ "Failed to contact node's " ++ Node.name node
+                   ++ " MonD for DC " ++ dName dc
+      return Nothing
+
+-- | Parse a node's JSON record.
+pMonDN :: JSRecord -> Result MonDData
+pMonDN a = do
+  node <- tryFromObj "Parsing node's name" a "node"
+  reports <- tryFromObj "Parsing node's reports" a "reports"
+  return (node, reports)
+
+-- | Parse MonD data file contents.
+pMonDData :: String -> Result [MonDData]
+pMonDData input =
+  loadJSArray "Parsing MonD's answer" input >>=
+  mapM (pMonDN . J.fromJSObject)
+
+-- | Query a single MonD for a single Data Collector.
+queryAMonD :: Maybe MapMonDData -> DataCollector -> Node.Node
+              -> IO (Maybe Report)
+queryAMonD m dc node =
+  liftM (mkReport dc) $ case m of
+      Nothing -> fromCurl dc node
+      Just m' -> return $ fromFile dc node m'
+
+-- | Query all MonDs for a single Data Collector. Return the updated
+-- cluster, as well as a bit inidicating wether the collector succeeded.
+queryAllMonDs :: Maybe MapMonDData -> (Node.List, Instance.List)
+                 -> DataCollector -> WriterT All IO (Node.List, Instance.List)
+queryAllMonDs m (nl, il) dc = do
+  elems <- liftIO $ mapM (queryAMonD m dc) (Container.elems nl)
+  let elems' = catMaybes elems
+  if length elems == length elems'
+    then
+      let results = zip (Container.elems nl) elems'
+      in case dUse dc results (nl, il) of
+        Ok (nl', il') -> return (nl', il')
+        Bad s -> do
+          logWarning s
+          tell $ All False
+          return (nl, il)
+    else do
+      logWarning $ "Didn't receive an answer by all MonDs, " ++ dName dc
+                   ++ "'s data will be ignored."
+      tell $ All False
+      return (nl,il)
+
+-- | Query all MonDs for all Data Collector. Return the cluster enriched
+-- by dynamic data, as well as a bit indicating wether all collectors
+-- could be queried successfully.
+queryAllMonDDCs :: ClusterData -> Options -> WriterT All IO ClusterData
+queryAllMonDDCs cdata opts = do
+  map_mDD <-
+    case optMonDFile opts of
+      Nothing -> return Nothing
+      Just fp -> do
+        monDData_contents <- liftIO $ readFile fp
+        monDData <- liftIO . exitIfBad "can't parse MonD data"
+                    . pMonDData $ monDData_contents
+        return . Just $ Map.fromList monDData
+  let (ClusterData _ nl il _ _) = cdata
+  (nl', il') <- foldM (queryAllMonDs map_mDD) (nl, il) (collectors opts)
+  return $ cdata {cdNodes = nl', cdInstances = il'}
index 72b8ab2..5aaa784 100644 (file)
@@ -204,7 +204,7 @@ serializeCluster (ClusterData gl nl il ctags cpol) =
 loadGroup :: (Monad m) => [String]
           -> m (String, Group.Group) -- ^ The result, a tuple of group
                                      -- UUID and group object
-loadGroup [name, gid, apol, tags, nets] = do
+loadGroup (name:gid:apol:tags:nets:_) = do
   xapol <- allocPolicyFromRaw apol
   let xtags = commaSplit tags
   let xnets = commaSplit nets
@@ -218,8 +218,8 @@ loadNode :: (Monad m) =>
          -> [String]              -- ^ Input data as a list of fields
          -> m (String, Node.Node) -- ^ The result, a tuple o node name
                                   -- and node object
-loadNode ktg [name, tm, nm, fm, td, fd, tc, fo, gu, spindles, tags,
-              excl_stor, free_spindles, nos_cpu, cpu_speed] = do
+loadNode ktg (name:tm:nm:fm:td:fd:tc:fo:gu:spindles:tags:
+              excl_stor:free_spindles:nos_cpu:cpu_speed:_) = do
   gdx <- lookupGroup ktg name gu
   new_node <-
       if "?" `elem` [tm,nm,fm,td,fd,tc] then
@@ -280,8 +280,8 @@ loadInst :: NameAssoc -- ^ Association list with the current nodes
          -> Result (String, Instance.Instance) -- ^ A tuple of
                                                -- instance name and
                                                -- the instance object
-loadInst ktn [ name, mem, dsk, vcpus, status, auto_bal, pnode, snode
-             , dt, tags, su, spindles, forthcoming_yn ] = do
+loadInst ktn (name:mem:dsk:vcpus:status:auto_bal:pnode:snode
+             :dt:tags:su:spindles:forthcoming_yn:_) = do
   pidx <- lookupNode ktn name pnode
   sidx <- if null snode
             then return Node.noSecondary
@@ -334,7 +334,7 @@ loadInst _ s = fail $ "Invalid/incomplete instance data: '" ++ show s ++ "'"
 
 -- | Loads a spec from a field list.
 loadISpec :: String -> [String] -> Result ISpec
-loadISpec owner [mem_s, cpu_c, dsk_s, dsk_c, nic_c, su] = do
+loadISpec owner (mem_s:cpu_c:dsk_s:dsk_c:nic_c:su:_) = do
   xmem_s <- tryRead (owner ++ "/memsize") mem_s
   xcpu_c <- tryRead (owner ++ "/cpucount") cpu_c
   xdsk_s <- tryRead (owner ++ "/disksize") dsk_s
@@ -369,8 +369,8 @@ loadMultipleMinMaxISpecs owner ispecs = do
 
 -- | Loads an ipolicy from a field list.
 loadIPolicy :: [String] -> Result (String, IPolicy)
-loadIPolicy [owner, stdspec, minmaxspecs, dtemplates,
-             vcpu_ratio, spindle_ratio] = do
+loadIPolicy (owner:stdspec:minmaxspecs:dtemplates:
+             vcpu_ratio:spindle_ratio:_) = do
   xstdspec <- loadISpec (owner ++ "/stdspec") (commaSplit stdspec)
   xminmaxspecs <- loadMultipleMinMaxISpecs owner $
                   sepSplit iSpecsSeparator minmaxspecs
@@ -434,10 +434,11 @@ parseData fdata = do
   let flines = lines fdata
   (glines, nlines, ilines, ctags, pollines) <-
       case sepSplit "" flines of
-        [a, b, c, d, e] -> Ok (a, b, c, d, e)
+        -- Ignore all additional fields
+        a:b:c:d:e:_ -> Ok (a, b, c, d, e)
         [a, b, c, d] -> Ok (a, b, c, d, [])
         xs -> Bad $ printf "Invalid format of the input file: %d sections\
-                           \ instead of 4 or 5" (length xs)
+                           \ instead of 4 or more" (length xs)
   {- group file: name uuid alloc_policy -}
   (ktg, gl) <- loadTabular glines loadGroup
   {- node file: name t_mem n_mem f_mem t_disk f_disk t_cpu offline grp_uuid
index 58f33c8..becd38d 100644 (file)
@@ -60,7 +60,10 @@ module Ganeti.HTools.CLI
   , oDynuFile
   , oMonD
   , oMonDDataFile
+  , oMonDXen
   , oEvacMode
+  , oMonDExitMissing
+  , oFirstJobGroup
   , oRestrictedMigrate
   , oExInst
   , oExTags
@@ -100,6 +103,7 @@ module Ganeti.HTools.CLI
   , oPrintNodes
   , oQuiet
   , oRapiMaster
+  , oReason
   , oSaveCluster
   , oSelInst
   , oShowHelp
@@ -111,6 +115,7 @@ module Ganeti.HTools.CLI
   , oTieredSpec
   , oVerbose
   , oPriority
+  , oNoCapacityChecks
   , genericOpts
   ) where
 
@@ -147,11 +152,16 @@ data Options = Options
   , optMonD        :: Bool           -- ^ Query MonDs
   , optMonDFile    :: Maybe FilePath -- ^ Optional file with data provided
                                      -- by MonDs
+  , optMonDXen     :: Bool           -- ^ Should Xen-specific collectors be
+                                     -- considered (only if MonD is queried)
+  , optMonDExitMissing :: Bool       -- ^ If the program should exit on missing
+                                     -- MonD data
   , optEvacMode    :: Bool           -- ^ Enable evacuation mode
   , optRestrictedMigrate :: Bool     -- ^ Disallow replace-primary moves
   , optExInst      :: [String]       -- ^ Instances to be excluded
   , optExTags      :: Maybe [String] -- ^ Tags to use for exclusion
   , optExecJobs    :: Bool           -- ^ Execute the commands via Luxi
+  , optFirstJobGroup :: Bool         -- ^ Only execute the first group of jobs
   , optForce       :: Bool           -- ^ Force the execution
   , optFullEvacuation :: Bool        -- ^ Fully evacuate nodes to be rebooted
   , optGroup       :: Maybe GroupID  -- ^ The UUID of the group to process
@@ -178,6 +188,8 @@ data Options = Options
   , optOneStepOnly :: Bool           -- ^ Only do the first step
   , optOutPath     :: FilePath       -- ^ Path to the output directory
   , optPrintMoves  :: Bool           -- ^ Whether to show the instance moves
+  , optReason      :: Maybe String   -- ^ The reason to be passed when
+                                     -- submitting jobs
   , optSaveCluster :: Maybe FilePath -- ^ Save cluster state to this file
   , optShowCmds    :: Maybe FilePath -- ^ Whether to show the command list
   , optShowHelp    :: Bool           -- ^ Just show the help
@@ -193,6 +205,7 @@ data Options = Options
   , optReplay      :: Maybe String   -- ^ Unittests: RNG state
   , optVerbose     :: Int            -- ^ Verbosity level
   , optPriority    :: Maybe OpSubmitPriority -- ^ OpCode submit priority
+  , optCapacity    :: Bool           -- ^ Also do capacity-related checks
   } deriving Show
 
 -- | Default values for the command line options.
@@ -210,11 +223,14 @@ defaultOptions  = Options
   , optDynuFile    = Nothing
   , optMonD        = False
   , optMonDFile = Nothing
+  , optMonDXen     = False
+  , optMonDExitMissing = False
   , optEvacMode    = False
   , optRestrictedMigrate = False
   , optExInst      = []
   , optExTags      = Nothing
   , optExecJobs    = False
+  , optFirstJobGroup = False
   , optForce       = False
   , optFullEvacuation = False
   , optGroup       = Nothing
@@ -242,6 +258,7 @@ defaultOptions  = Options
   , optOneStepOnly = False
   , optOutPath     = "."
   , optPrintMoves  = False
+  , optReason      = Nothing
   , optSaveCluster = Nothing
   , optShowCmds    = Nothing
   , optShowHelp    = False
@@ -256,6 +273,7 @@ defaultOptions  = Options
   , optReplay      = Nothing
   , optVerbose     = 1
   , optPriority    = Nothing
+  , optCapacity    = True
   }
 
 -- | Abbreviation for the option type.
@@ -331,6 +349,20 @@ oMonDDataFile =
    "Import data provided by MonDs from the given FILE",
    OptComplFile)
 
+oMonDXen :: OptType
+oMonDXen =
+  (Option "" ["mond-xen"]
+    (NoArg (\ opts -> Ok opts { optMonDXen = True }))
+    "also consider xen-specific collectors in MonD queries",
+    OptComplNone)
+
+oMonDExitMissing :: OptType
+oMonDExitMissing =
+  (Option "" ["exit-on-missing-mond-data"]
+    (NoArg (\ opts -> Ok opts { optMonDExitMissing = True }))
+    "abort if the data available from the monitoring daemons is incomplete",
+    OptComplNone)
+
 oDiskTemplate :: OptType
 oDiskTemplate =
   (Option "" ["disk-template"]
@@ -440,6 +472,20 @@ oExecJobs =
    \ it for data gathering)",
    OptComplNone)
 
+oReason :: OptType
+oReason =
+  (Option "" ["reason"]
+   (ReqArg (\ f opts -> Ok opts { optReason = Just f }) "REASON")
+   "The reason to pass to the submitted jobs",
+   OptComplNone)
+
+oFirstJobGroup :: OptType
+oFirstJobGroup =
+  (Option "" ["first-job-group"]
+   (NoArg (\ opts -> Ok opts {optFirstJobGroup = True}))
+   "only execute the first group of jobs",
+   OptComplNone)
+
 oForce :: OptType
 oForce =
   (Option "f" ["force"]
@@ -568,7 +614,7 @@ oMinScore =
   (Option "e" ["min-score"]
    (reqWithConversion (tryRead "min score")
     (\e opts -> Ok opts { optMinScore = e }) "EPSILON")
-   "mininum score to aim for",
+   "mininum excess to the N+1 limit to aim for",
    OptComplFloat)
 
 oNoHeaders :: OptType
@@ -740,6 +786,13 @@ oPriority =
    "set the priority of submitted jobs",
     OptComplChoices (map fmtSubmitPriority [minBound..maxBound]))
 
+oNoCapacityChecks :: OptType
+oNoCapacityChecks =
+  (Option "" ["no-capacity-checks"]
+   (NoArg (\ opts -> Ok opts { optCapacity = False}))
+   "disable capacity checks (like global N+1 redundancy)",
+   OptComplNone)
+
 -- | Generic options.
 genericOpts :: [GenericOptType Options]
 genericOpts =  [ oShowVer
index 55cbb6b..662f150 100644 (file)
@@ -39,17 +39,24 @@ module Ganeti.HTools.Cluster
   (
     -- * Types
     AllocDetails(..)
-  , AllocSolution(..)
-  , EvacSolution(..)
+  , GenericAllocSolution(..)
+  , AllocSolution
+  , emptyAllocSolution
+  , concatAllocs
+  , sumAllocs
+  , updateIl
+  , extractNl
   , Table(..)
   , CStats(..)
   , AllocNodes
   , AllocResult
   , AllocMethod
+  , GenericAllocSolutionList
   , AllocSolutionList
   -- * Generic functions
   , totalResources
   , computeAllocationDelta
+  , hasRequiredNetworks
   -- * First phase functions
   , computeBadItems
   -- * Second phase functions
@@ -61,21 +68,19 @@ module Ganeti.HTools.Cluster
   -- * Display functions
   , printNodes
   , printInsts
+  , genericAnnotateSolution
+  , solutionDescription
   -- * Balacing functions
-  , setInstanceLocationScore
   , doNextBalance
   , tryBalance
-  , compCV
-  , compCVNodes
-  , compDetailedCV
-  , printStats
   , iMoveToJob
   -- * IAllocator functions
   , genAllocNodes
   , tryAlloc
   , tryGroupAlloc
   , tryMGAlloc
-  , tryNodeEvac
+  , filterMGResults
+  , sortMGResults
   , tryChangeGroup
   , collapseFailures
   , allocList
@@ -85,7 +90,6 @@ module Ganeti.HTools.Cluster
   -- * Node group functions
   , instanceGroup
   , findSplitInstances
-  , splitCluster
   ) where
 
 import Control.Applicative ((<$>), liftA2)
@@ -96,22 +100,28 @@ import Data.List
 import Data.Maybe (fromJust, fromMaybe, isJust, isNothing)
 import Data.Ord (comparing)
 import Text.Printf (printf)
-import qualified Data.Set as Set
 
 import Ganeti.BasicTypes
-import qualified Ganeti.Constants as C
 import Ganeti.HTools.AlgorithmParams (AlgorithmOptions(..), defaultOptions)
 import qualified Ganeti.HTools.Container as Container
+import Ganeti.HTools.Cluster.Evacuate ( EvacSolution(..), emptyEvacSolution
+                                      , updateEvacSolution, reverseEvacSolution
+                                      , nodeEvacInstance)
+import Ganeti.HTools.Cluster.Metrics ( compCV, compCVfromStats
+                                     , compClusterStatistics
+                                     , updateClusterStatisticsTwice)
+import Ganeti.HTools.Cluster.Moves (setInstanceLocationScore, applyMoveEx)
+import Ganeti.HTools.Cluster.Utils (splitCluster, instancePriGroup
+                                   , availableGroupNodes, iMoveToJob)
 import qualified Ganeti.HTools.Instance as Instance
 import qualified Ganeti.HTools.Nic as Nic
 import qualified Ganeti.HTools.Node as Node
 import qualified Ganeti.HTools.Group as Group
 import Ganeti.HTools.Types
 import Ganeti.Compat
-import qualified Ganeti.OpCodes as OpCodes
 import Ganeti.Utils
 import Ganeti.Utils.Statistics
-import Ganeti.Types (EvacMode(..), mkNonEmpty, mkNonNegative)
+import Ganeti.Types (EvacMode(..))
 
 -- * Types
 
@@ -122,29 +132,23 @@ data AllocDetails = AllocDetails Int (Maybe String)
                     deriving (Show)
 
 -- | Allocation\/relocation solution.
-data AllocSolution = AllocSolution
+data GenericAllocSolution a = AllocSolution
   { asFailures :: [FailMode]              -- ^ Failure counts
   , asAllocs   :: Int                     -- ^ Good allocation count
-  , asSolution :: Maybe Node.AllocElement -- ^ The actual allocation result
+  , asSolution :: Maybe (Node.GenericAllocElement a) -- ^ The actual allocation
+                                          -- result
   , asLog      :: [String]                -- ^ Informational messages
   }
 
--- | Node evacuation/group change iallocator result type. This result
--- type consists of actual opcodes (a restricted subset) that are
--- transmitted back to Ganeti.
-data EvacSolution = EvacSolution
-  { esMoved   :: [(Idx, Gdx, [Ndx])]  -- ^ Instances moved successfully
-  , esFailed  :: [(Idx, String)]      -- ^ Instances which were not
-                                      -- relocated
-  , esOpCodes :: [[OpCodes.OpCode]]   -- ^ List of jobs
-  } deriving (Show)
+type AllocSolution = GenericAllocSolution Score
 
 -- | Allocation results, as used in 'iterateAlloc' and 'tieredAlloc'.
 type AllocResult = (FailStats, Node.List, Instance.List,
                     [Instance.Instance], [CStats])
 
 -- | Type alias for easier handling.
-type AllocSolutionList = [(Instance.Instance, AllocSolution)]
+type GenericAllocSolutionList a = [(Instance.Instance, GenericAllocSolution a)]
+type AllocSolutionList = GenericAllocSolutionList Score
 
 -- | A type denoting the valid allocation mode/pairs.
 --
@@ -156,17 +160,10 @@ type AllocSolutionList = [(Instance.Instance, AllocSolution)]
 type AllocNodes = Either [Ndx] [(Ndx, [Ndx])]
 
 -- | The empty solution we start with when computing allocations.
-emptyAllocSolution :: AllocSolution
+emptyAllocSolution :: GenericAllocSolution a
 emptyAllocSolution = AllocSolution { asFailures = [], asAllocs = 0
                                    , asSolution = Nothing, asLog = [] }
 
--- | The empty evac solution.
-emptyEvacSolution :: EvacSolution
-emptyEvacSolution = EvacSolution { esMoved = []
-                                 , esFailed = []
-                                 , esOpCodes = []
-                                 }
-
 -- | The complete state for the balancing solution.
 data Table = Table Node.List Instance.List Score [Placement]
              deriving (Show)
@@ -209,10 +206,6 @@ type AllocMethod =  Node.List           -- ^ Node list
                  -> [CStats]            -- ^ Running cluster stats
                  -> Result AllocResult  -- ^ Allocation result
 
--- | A simple type for the running solution of evacuations.
-type EvacInnerState =
-  Either String (Node.List, Instance.Instance, Score, Ndx)
-
 -- * Utility functions
 
 -- | Verifies the N+1 status and return the affected nodes.
@@ -236,18 +229,6 @@ computeBadItems nl il =
   in
     (bad_nodes, bad_instances)
 
--- | Extracts the node pairs for an instance. This can fail if the
--- instance is single-homed. FIXME: this needs to be improved,
--- together with the general enhancement for handling non-DRBD moves.
-instanceNodes :: Node.List -> Instance.Instance ->
-                 (Ndx, Ndx, Node.Node, Node.Node)
-instanceNodes nl inst =
-  let old_pdx = Instance.pNode inst
-      old_sdx = Instance.sNode inst
-      old_p = Container.find old_pdx nl
-      old_s = Container.find old_sdx nl
-  in (old_pdx, old_sdx, old_p, old_s)
-
 -- | Zero-initializer for the CStats type.
 emptyCStats :: CStats
 emptyCStats = CStats 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
@@ -341,146 +322,10 @@ computeAllocationDelta cini cfin =
                        }
   in (rini, rfin, runa)
 
--- | The names and weights of the individual elements in the CV list, together
--- with their statistical accumulation function and a bit to decide whether it
--- is a statistics for online nodes.
-detailedCVInfoExt :: [((Double, String), ([Double] -> Statistics, Bool))]
-detailedCVInfoExt = [ ((0.5,  "free_mem_cv"), (getStdDevStatistics, True))
-                    , ((0.5,  "free_disk_cv"), (getStdDevStatistics, True))
-                    , ((1,  "n1_cnt"), (getSumStatistics, True))
-                    , ((1,  "reserved_mem_cv"), (getStdDevStatistics, True))
-                    , ((4,  "offline_all_cnt"), (getSumStatistics, False))
-                    , ((16, "offline_pri_cnt"), (getSumStatistics, False))
-                    , ( (0.5,  "vcpu_ratio_cv")
-                      , (getStdDevStatistics, True))
-                    , ((1,  "cpu_load_cv"), (getStdDevStatistics, True))
-                    , ((1,  "mem_load_cv"), (getStdDevStatistics, True))
-                    , ((1,  "disk_load_cv"), (getStdDevStatistics, True))
-                    , ((1,  "net_load_cv"), (getStdDevStatistics, True))
-                    , ((2,  "pri_tags_score"), (getSumStatistics, True))
-                    , ((0.5,  "spindles_cv"), (getStdDevStatistics, True))
-                    , ((0.5,  "free_mem_cv_forth"), (getStdDevStatistics, True))
-                    , ( (0.5,  "free_disk_cv_forth")
-                      , (getStdDevStatistics, True))
-                    , ( (0.5,  "vcpu_ratio_cv_forth")
-                      , (getStdDevStatistics, True))
-                    , ((0.5,  "spindles_cv_forth"), (getStdDevStatistics, True))
-                    , ((1,  "location_score"), (getSumStatistics, True))
-                    ]
-
--- | The names and weights of the individual elements in the CV list.
-detailedCVInfo :: [(Double, String)]
-detailedCVInfo = map fst detailedCVInfoExt
-
--- | Holds the weights used by 'compCVNodes' for each metric.
-detailedCVWeights :: [Double]
-detailedCVWeights = map fst detailedCVInfo
-
--- | The aggregation functions for the weights
-detailedCVAggregation :: [([Double] -> Statistics, Bool)]
-detailedCVAggregation = map snd detailedCVInfoExt
-
--- | The bit vector describing which parts of the statistics are
--- for online nodes.
-detailedCVOnlineStatus :: [Bool]
-detailedCVOnlineStatus = map snd detailedCVAggregation
-
--- | Compute statistical measures of a single node.
-compDetailedCVNode :: Node.Node -> [Double]
-compDetailedCVNode node =
-  let mem = Node.pMem node
-      memF = Node.pMemForth node
-      dsk = Node.pDsk node
-      dskF = Node.pDskForth node
-      n1 = fromIntegral
-           $ if Node.failN1 node
-               then length (Node.sList node) + length (Node.pList node)
-               else 0
-      res = Node.pRem node
-      ipri = fromIntegral . length $ Node.pList node
-      isec = fromIntegral . length $ Node.sList node
-      ioff = ipri + isec
-      cpu = Node.pCpuEff node
-      cpuF = Node.pCpuEffForth node
-      DynUtil c1 m1 d1 nn1 = Node.utilLoad node
-      DynUtil c2 m2 d2 nn2 = Node.utilPool node
-      (c_load, m_load, d_load, n_load) = (c1/c2, m1/m2, d1/d2, nn1/nn2)
-      pri_tags = fromIntegral $ Node.conflictingPrimaries node
-      spindles = Node.instSpindles node / Node.hiSpindles node
-      spindlesF = Node.instSpindlesForth node / Node.hiSpindles node
-      location_score = fromIntegral $ Node.locationScore node
-  in [ mem, dsk, n1, res, ioff, ipri, cpu
-     , c_load, m_load, d_load, n_load
-     , pri_tags, spindles
-     , memF, dskF, cpuF, spindlesF
-     , location_score
-     ]
-
--- | Compute the statistics of a cluster.
-compClusterStatistics :: [Node.Node] -> [Statistics]
-compClusterStatistics all_nodes =
-  let (offline, nodes) = partition Node.offline all_nodes
-      offline_values = transpose (map compDetailedCVNode offline)
-                       ++ repeat []
-      -- transpose of an empty list is empty and not k times the empty list, as
-      -- would be the transpose of a 0 x k matrix
-      online_values = transpose $ map compDetailedCVNode nodes
-      aggregate (f, True) (onNodes, _) = f onNodes
-      aggregate (f, False) (_, offNodes) = f offNodes
-  in zipWith aggregate detailedCVAggregation
-       $ zip online_values offline_values
-
--- | Update a cluster statistics by replacing the contribution of one
--- node by that of another.
-updateClusterStatistics :: [Statistics]
-                           -> (Node.Node, Node.Node) -> [Statistics]
-updateClusterStatistics stats (old, new) =
-  let update = zip (compDetailedCVNode old) (compDetailedCVNode new)
-      online = not $ Node.offline old
-      updateStat forOnline stat upd = if forOnline == online
-                                        then updateStatistics stat upd
-                                        else stat
-  in zipWith3 updateStat detailedCVOnlineStatus stats update
-
--- | Update a cluster statistics twice.
-updateClusterStatisticsTwice :: [Statistics]
-                                -> (Node.Node, Node.Node)
-                                -> (Node.Node, Node.Node)
-                                -> [Statistics]
-updateClusterStatisticsTwice s a =
-  updateClusterStatistics (updateClusterStatistics s a)
-
--- | Compute cluster statistics
-compDetailedCV :: [Node.Node] -> [Double]
-compDetailedCV = map getStatisticValue . compClusterStatistics
-
--- | Compute the cluster score from its statistics
-compCVfromStats :: [Statistics] -> Double
-compCVfromStats = sum . zipWith (*) detailedCVWeights . map getStatisticValue
-
--- | Compute the /total/ variance.
-compCVNodes :: [Node.Node] -> Double
-compCVNodes = sum . zipWith (*) detailedCVWeights . compDetailedCV
-
--- | Wrapper over 'compCVNodes' for callers that have a 'Node.List'.
-compCV :: Node.List -> Double
-compCV = compCVNodes . Container.elems
-
 -- | Compute online nodes from a 'Node.List'.
 getOnline :: Node.List -> [Node.Node]
 getOnline = filter (not . Node.offline) . Container.elems
 
--- | Sets the location score of an instance, given its primary
--- and secondary node.
-setInstanceLocationScore :: Instance.Instance -- ^ the original instance
-                         -> Node.Node -- ^ the primary node of the instance
-                         -> Node.Node -- ^ the secondary node of the instance
-                         -> Instance.Instance -- ^ the instance with the
-                                              -- location score updated
-setInstanceLocationScore t p s =
-  t { Instance.locationScore =
-         Set.size $ Node.locationTags p `Set.intersection` Node.locationTags s }
-
 -- * Balancing functions
 
 -- | Compute best table. Note that the ordering of the arguments is important.
@@ -488,116 +333,6 @@ compareTables :: Table -> Table -> Table
 compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
   if a_cv > b_cv then b else a
 
--- | Applies an instance move to a given node list and instance.
-applyMoveEx :: Bool -- ^ whether to ignore soft errors
-               -> Node.List -> Instance.Instance
-               -> IMove -> OpResult (Node.List, Instance.Instance, Ndx, Ndx)
--- Failover (f)
-applyMoveEx force nl inst Failover =
-  let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
-      int_p = Node.removePri old_p inst
-      int_s = Node.removeSec old_s inst
-      new_nl = do -- OpResult
-        Node.checkMigration old_p old_s
-        new_p <- Node.addPriEx (Node.offline old_p || force) int_s inst
-        new_s <- Node.addSecExEx (Node.offline old_p) (Node.offline old_p)
-                   int_p inst old_sdx
-        let new_inst = Instance.setBoth inst old_sdx old_pdx
-        return (Container.addTwo old_pdx new_s old_sdx new_p nl,
-                new_inst, old_sdx, old_pdx)
-  in new_nl
-
--- Failover to any (fa)
-applyMoveEx force nl inst (FailoverToAny new_pdx) = do
-  let (old_pdx, old_sdx, old_pnode, _) = instanceNodes nl inst
-      new_pnode = Container.find new_pdx nl
-      force_failover = Node.offline old_pnode || force
-  Node.checkMigration old_pnode new_pnode
-  new_pnode' <- Node.addPriEx force_failover new_pnode inst
-  let old_pnode' = Node.removePri old_pnode inst
-      inst' = Instance.setPri inst new_pdx
-      nl' = Container.addTwo old_pdx old_pnode' new_pdx new_pnode' nl
-  return (nl', inst', new_pdx, old_sdx)
-
--- Replace the primary (f:, r:np, f)
-applyMoveEx force nl inst (ReplacePrimary new_pdx) =
-  let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
-      tgt_n = Container.find new_pdx nl
-      int_p = Node.removePri old_p inst
-      int_s = Node.removeSec old_s inst
-      new_inst = Instance.setPri (setInstanceLocationScore inst tgt_n int_s)
-                 new_pdx
-      force_p = Node.offline old_p || force
-      new_nl = do -- OpResult
-                  -- check that the current secondary can host the instance
-                  -- during the migration
-        Node.checkMigration old_p old_s
-        Node.checkMigration old_s tgt_n
-        tmp_s <- Node.addPriEx force_p int_s new_inst
-        let tmp_s' = Node.removePri tmp_s new_inst
-        new_p <- Node.addPriEx force_p tgt_n new_inst
-        new_s <- Node.addSecEx force_p tmp_s' new_inst new_pdx
-        return (Container.add new_pdx new_p $
-                Container.addTwo old_pdx int_p old_sdx new_s nl,
-                new_inst, new_pdx, old_sdx)
-  in new_nl
-
--- Replace the secondary (r:ns)
-applyMoveEx force nl inst (ReplaceSecondary new_sdx) =
-  let old_pdx = Instance.pNode inst
-      old_sdx = Instance.sNode inst
-      old_s = Container.find old_sdx nl
-      tgt_n = Container.find new_sdx nl
-      pnode = Container.find old_pdx nl
-      pnode' = Node.removePri pnode inst
-      int_s = Node.removeSec old_s inst
-      force_s = Node.offline old_s || force
-      new_inst = Instance.setSec (setInstanceLocationScore inst pnode tgt_n)
-                 new_sdx
-      new_nl = do
-        new_s <- Node.addSecEx force_s tgt_n new_inst old_pdx
-        pnode'' <- Node.addPriEx True pnode' new_inst
-        return (Container.add old_pdx pnode'' $
-                Container.addTwo new_sdx new_s old_sdx int_s nl,
-                new_inst, old_pdx, new_sdx)
-  in new_nl
-
--- Replace the secondary and failover (r:np, f)
-applyMoveEx force nl inst (ReplaceAndFailover new_pdx) =
-  let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
-      tgt_n = Container.find new_pdx nl
-      int_p = Node.removePri old_p inst
-      int_s = Node.removeSec old_s inst
-      new_inst = Instance.setBoth (setInstanceLocationScore inst tgt_n int_p)
-                 new_pdx old_pdx
-      force_s = Node.offline old_s || force
-      new_nl = do -- OpResult
-        Node.checkMigration old_p tgt_n
-        new_p <- Node.addPriEx force tgt_n new_inst
-        new_s <- Node.addSecEx force_s int_p new_inst new_pdx
-        return (Container.add new_pdx new_p $
-                Container.addTwo old_pdx new_s old_sdx int_s nl,
-                new_inst, new_pdx, old_pdx)
-  in new_nl
-
--- Failver and replace the secondary (f, r:ns)
-applyMoveEx force nl inst (FailoverAndReplace new_sdx) =
-  let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
-      tgt_n = Container.find new_sdx nl
-      int_p = Node.removePri old_p inst
-      int_s = Node.removeSec old_s inst
-      force_p = Node.offline old_p || force
-      new_inst = Instance.setBoth (setInstanceLocationScore inst int_s tgt_n)
-                 old_sdx new_sdx
-      new_nl = do -- OpResult
-        Node.checkMigration old_p old_s
-        new_p <- Node.addPriEx force_p int_s new_inst
-        new_s <- Node.addSecEx force_p tgt_n new_inst old_sdx
-        return (Container.add new_sdx new_s $
-                Container.addTwo old_sdx new_p old_pdx int_p nl,
-                new_inst, old_sdx, new_sdx)
-  in new_nl
-
 -- | Tries to allocate an instance on one given node.
 allocateOnSingle :: AlgorithmOptions
                  -> Node.List -> Instance.Instance -> Ndx
@@ -800,9 +535,10 @@ collapseFailures flst =
             [minBound..maxBound]
 
 -- | Compares two Maybe AllocElement and chooses the best score.
-bestAllocElement :: Maybe Node.AllocElement
-                 -> Maybe Node.AllocElement
-                 -> Maybe Node.AllocElement
+bestAllocElement :: Ord a
+                 => Maybe (Node.GenericAllocElement a)
+                 -> Maybe (Node.GenericAllocElement a)
+                 -> Maybe (Node.GenericAllocElement a)
 bestAllocElement a Nothing = a
 bestAllocElement Nothing b = b
 bestAllocElement a@(Just (_, _, _, ascore)) b@(Just (_, _, _, bscore)) =
@@ -810,7 +546,10 @@ bestAllocElement a@(Just (_, _, _, ascore)) b@(Just (_, _, _, bscore)) =
 
 -- | Update current Allocation solution and failure stats with new
 -- elements.
-concatAllocs :: AllocSolution -> OpResult Node.AllocElement -> AllocSolution
+concatAllocs :: Ord a
+             => GenericAllocSolution a
+             -> OpResult (Node.GenericAllocElement a)
+             -> GenericAllocSolution a
 concatAllocs as (Bad reason) = as { asFailures = reason : asFailures as }
 
 concatAllocs as (Ok ns) =
@@ -827,7 +566,10 @@ concatAllocs as (Ok ns) =
   in nsols `seq` nsuc `seq` as { asAllocs = nsuc, asSolution = nsols }
 
 -- | Sums two 'AllocSolution' structures.
-sumAllocs :: AllocSolution -> AllocSolution -> AllocSolution
+sumAllocs :: Ord a
+          => GenericAllocSolution a
+          -> GenericAllocSolution a
+          -> GenericAllocSolution a
 sumAllocs (AllocSolution aFails aAllocs aSols aLog)
           (AllocSolution bFails bAllocs bSols bLog) =
   -- note: we add b first, since usually it will be smaller; when
@@ -840,8 +582,8 @@ sumAllocs (AllocSolution aFails aAllocs aSols aLog)
   in AllocSolution nFails nAllocs nSols nLog
 
 -- | Given a solution, generates a reasonable description for it.
-describeSolution :: AllocSolution -> String
-describeSolution as =
+genericDescribeSolution :: (a -> String) -> GenericAllocSolution a -> String
+genericDescribeSolution formatMetrics as =
   let fcnt = asFailures as
       sols = asSolution as
       freasons =
@@ -851,21 +593,20 @@ describeSolution as =
      Nothing -> "No valid allocation solutions, failure reasons: " ++
                 (if null fcnt then "unknown reasons" else freasons)
      Just (_, _, nodes, cv) ->
-         printf ("score: %.8f, successes %d, failures %d (%s)" ++
-                 " for node(s) %s") cv (asAllocs as) (length fcnt) freasons
+         printf ("score: %s, successes %d, failures %d (%s)" ++
+                 " for node(s) %s") (formatMetrics cv) (asAllocs as)
+               (length fcnt) freasons
                (intercalate "/" . map Node.name $ nodes)
 
 -- | Annotates a solution with the appropriate string.
-annotateSolution :: AllocSolution -> AllocSolution
-annotateSolution as = as { asLog = describeSolution as : asLog as }
+genericAnnotateSolution :: (a -> String)
+                        ->GenericAllocSolution a -> GenericAllocSolution a
+genericAnnotateSolution formatMetrics as =
+  as { asLog = genericDescribeSolution formatMetrics as : asLog as }
 
--- | Reverses an evacuation solution.
---
--- Rationale: we always concat the results to the top of the lists, so
--- for proper jobset execution, we should reverse all lists.
-reverseEvacSolution :: EvacSolution -> EvacSolution
-reverseEvacSolution (EvacSolution f m o) =
-  EvacSolution (reverse f) (reverse m) (reverse o)
+-- | Annotate a solution based on the standard metrics
+annotateSolution :: AllocSolution -> AllocSolution
+annotateSolution = genericAnnotateSolution (printf "%.8f")
 
 -- | Generate the valid node allocation singles or pairs for a new instance.
 genAllocNodes :: Group.List        -- ^ Group list
@@ -917,7 +658,7 @@ tryAlloc opts nl _ inst (Left all_nodes) =
   in return $ annotateSolution sols
 
 -- | Given a group/result, describe it as a nice (list of) messages.
-solutionDescription :: (Group.Group, Result AllocSolution)
+solutionDescription :: (Group.Group, Result (GenericAllocSolution a))
                     -> [String]
 solutionDescription (grp, result) =
   case result of
@@ -929,8 +670,8 @@ solutionDescription (grp, result) =
 -- | From a list of possibly bad and possibly empty solutions, filter
 -- only the groups with a valid result. Note that the result will be
 -- reversed compared to the original list.
-filterMGResults :: [(Group.Group, Result AllocSolution)]
-                -> [(Group.Group, AllocSolution)]
+filterMGResults :: [(Group.Group, Result (GenericAllocSolution a))]
+                -> [(Group.Group, GenericAllocSolution a)]
 filterMGResults = foldl' fn []
   where unallocable = not . Group.isAllocable
         fn accu (grp, rasol) =
@@ -941,8 +682,9 @@ filterMGResults = foldl' fn []
                    | otherwise -> (grp, sol):accu
 
 -- | Sort multigroup results based on policy and score.
-sortMGResults :: [(Group.Group, AllocSolution)]
-              -> [(Group.Group, AllocSolution)]
+sortMGResults :: Ord a
+              => [(Group.Group, GenericAllocSolution a)]
+              -> [(Group.Group, GenericAllocSolution a)]
 sortMGResults sols =
   let extractScore (_, _, _, x) = x
       solScore (grp, sol) = (Group.allocPolicy grp,
@@ -1056,14 +798,16 @@ tryGroupAlloc opts mggl mgnl ngil gn inst cnt = do
 
 -- | Calculate the new instance list after allocation solution.
 updateIl :: Instance.List           -- ^ The original instance list
-         -> Maybe Node.AllocElement -- ^ The result of the allocation attempt
+         -> Maybe (Node.GenericAllocElement a) -- ^ The result of
+                                               -- the allocation attempt
          -> Instance.List           -- ^ The updated instance list
 updateIl il Nothing = il
 updateIl il (Just (_, xi, _, _)) = Container.add (Container.size il) xi il
 
 -- | Extract the the new node list from the allocation solution.
 extractNl :: Node.List               -- ^ The original node list
-          -> Maybe Node.AllocElement -- ^ The result of the allocation attempt
+          -> Maybe (Node.GenericAllocElement a) -- ^ The result of the
+                                                -- allocation attempt
           -> Node.List               -- ^ The new node list
 extractNl nl Nothing = nl
 extractNl _ (Just (xnl, _, _, _)) = xnl
@@ -1090,317 +834,7 @@ allocList opts gl nl il ((xi, AllocDetails xicnt mgn):xies) result = do
       il' = updateIl il sol
   allocList opts gl nl' il' xies ((xi, ares):result)
 
--- | Function which fails if the requested mode is change secondary.
---
--- This is useful since except DRBD, no other disk template can
--- execute change secondary; thus, we can just call this function
--- instead of always checking for secondary mode. After the call to
--- this function, whatever mode we have is just a primary change.
-failOnSecondaryChange :: (Monad m) => EvacMode -> DiskTemplate -> m ()
-failOnSecondaryChange ChangeSecondary dt =
-  fail $ "Instances with disk template '" ++ diskTemplateToRaw dt ++
-         "' can't execute change secondary"
-failOnSecondaryChange _ _ = return ()
-
--- | Run evacuation for a single instance.
---
--- /Note:/ this function should correctly execute both intra-group
--- evacuations (in all modes) and inter-group evacuations (in the
--- 'ChangeAll' mode). Of course, this requires that the correct list
--- of target nodes is passed.
-nodeEvacInstance :: AlgorithmOptions
-                 -> Node.List         -- ^ The node list (cluster-wide)
-                 -> Instance.List     -- ^ Instance list (cluster-wide)
-                 -> EvacMode          -- ^ The evacuation mode
-                 -> Instance.Instance -- ^ The instance to be evacuated
-                 -> Gdx               -- ^ The group we're targetting
-                 -> [Ndx]             -- ^ The list of available nodes
-                                      -- for allocation
-                 -> Result (Node.List, Instance.List, [OpCodes.OpCode])
-nodeEvacInstance opts nl il mode inst@(Instance.Instance
-                                    {Instance.diskTemplate = dt@DTDiskless})
-                 gdx avail_nodes =
-                   failOnSecondaryChange mode dt >>
-                   evacOneNodeOnly opts nl il inst gdx avail_nodes
-
-nodeEvacInstance _ _ _ _ (Instance.Instance
-                          {Instance.diskTemplate = DTPlain}) _ _ =
-                  fail "Instances of type plain cannot be relocated"
-
-nodeEvacInstance _ _ _ _ (Instance.Instance
-                          {Instance.diskTemplate = DTFile}) _ _ =
-                  fail "Instances of type file cannot be relocated"
-
-nodeEvacInstance opts nl il mode inst@(Instance.Instance
-                                    {Instance.diskTemplate = dt@DTSharedFile})
-                 gdx avail_nodes =
-                   failOnSecondaryChange mode dt >>
-                   evacOneNodeOnly opts nl il inst gdx avail_nodes
-
-nodeEvacInstance opts nl il mode inst@(Instance.Instance
-                                    {Instance.diskTemplate = dt@DTBlock})
-                 gdx avail_nodes =
-                   failOnSecondaryChange mode dt >>
-                   evacOneNodeOnly opts nl il inst gdx avail_nodes
-
-nodeEvacInstance opts nl il mode inst@(Instance.Instance
-                                    {Instance.diskTemplate = dt@DTRbd})
-                 gdx avail_nodes =
-                   failOnSecondaryChange mode dt >>
-                   evacOneNodeOnly opts nl il inst gdx avail_nodes
-
-nodeEvacInstance opts nl il mode inst@(Instance.Instance
-                                    {Instance.diskTemplate = dt@DTExt})
-                 gdx avail_nodes =
-                   failOnSecondaryChange mode dt >>
-                   evacOneNodeOnly opts nl il inst gdx avail_nodes
-
-nodeEvacInstance opts nl il mode inst@(Instance.Instance
-                                    {Instance.diskTemplate = dt@DTGluster})
-                 gdx avail_nodes =
-                   failOnSecondaryChange mode dt >>
-                   evacOneNodeOnly opts nl il inst gdx avail_nodes
-
-nodeEvacInstance opts nl il ChangePrimary
-                 inst@(Instance.Instance {Instance.diskTemplate = DTDrbd8})
-                 _ _ =
-  do
-    (nl', inst', _, _) <- opToResult
-                          $ applyMoveEx (algIgnoreSoftErrors opts) nl inst
-                            Failover
-    let idx = Instance.idx inst
-        il' = Container.add idx inst' il
-        ops = iMoveToJob nl' il' idx Failover
-    return (nl', il', ops)
-
-nodeEvacInstance opts nl il ChangeSecondary
-                 inst@(Instance.Instance {Instance.diskTemplate = DTDrbd8})
-                 gdx avail_nodes =
-  evacOneNodeOnly opts nl il inst gdx avail_nodes
-
--- The algorithm for ChangeAll is as follows:
---
--- * generate all (primary, secondary) node pairs for the target groups
--- * for each pair, execute the needed moves (r:s, f, r:s) and compute
---   the final node list state and group score
--- * select the best choice via a foldl that uses the same Either
---   String solution as the ChangeSecondary mode
-nodeEvacInstance opts nl il ChangeAll
-                 inst@(Instance.Instance {Instance.diskTemplate = DTDrbd8})
-                 gdx avail_nodes =
-  do
-    let no_nodes = Left "no nodes available"
-        node_pairs = [(p,s) | p <- avail_nodes, s <- avail_nodes, p /= s]
-    (nl', il', ops, _) <-
-        annotateResult "Can't find any good nodes for relocation" .
-        eitherToResult $
-        foldl'
-        (\accu nodes -> case evacDrbdAllInner opts nl il inst gdx nodes of
-                          Bad msg ->
-                              case accu of
-                                Right _ -> accu
-                                -- we don't need more details (which
-                                -- nodes, etc.) as we only selected
-                                -- this group if we can allocate on
-                                -- it, hence failures will not
-                                -- propagate out of this fold loop
-                                Left _ -> Left $ "Allocation failed: " ++ msg
-                          Ok result@(_, _, _, new_cv) ->
-                              let new_accu = Right result in
-                              case accu of
-                                Left _ -> new_accu
-                                Right (_, _, _, old_cv) ->
-                                    if old_cv < new_cv
-                                    then accu
-                                    else new_accu
-        ) no_nodes node_pairs
-
-    return (nl', il', ops)
-
--- | Generic function for changing one node of an instance.
---
--- This is similar to 'nodeEvacInstance' but will be used in a few of
--- its sub-patterns. It folds the inner function 'evacOneNodeInner'
--- over the list of available nodes, which results in the best choice
--- for relocation.
-evacOneNodeOnly :: AlgorithmOptions
-                -> Node.List         -- ^ The node list (cluster-wide)
-                -> Instance.List     -- ^ Instance list (cluster-wide)
-                -> Instance.Instance -- ^ The instance to be evacuated
-                -> Gdx               -- ^ The group we're targetting
-                -> [Ndx]             -- ^ The list of available nodes
-                                      -- for allocation
-                -> Result (Node.List, Instance.List, [OpCodes.OpCode])
-evacOneNodeOnly opts nl il inst gdx avail_nodes = do
-  op_fn <- case Instance.mirrorType inst of
-             MirrorNone -> Bad "Can't relocate/evacuate non-mirrored instances"
-             MirrorInternal -> Ok ReplaceSecondary
-             MirrorExternal -> Ok FailoverToAny
-  (nl', inst', _, ndx) <- annotateResult "Can't find any good node" .
-                          eitherToResult $
-                          foldl' (evacOneNodeInner opts nl inst gdx op_fn)
-                          (Left "") avail_nodes
-  let idx = Instance.idx inst
-      il' = Container.add idx inst' il
-      ops = iMoveToJob nl' il' idx (op_fn ndx)
-  return (nl', il', ops)
-
--- | Inner fold function for changing one node of an instance.
---
--- Depending on the instance disk template, this will either change
--- the secondary (for DRBD) or the primary node (for shared
--- storage). However, the operation is generic otherwise.
---
--- The running solution is either a @Left String@, which means we
--- don't have yet a working solution, or a @Right (...)@, which
--- represents a valid solution; it holds the modified node list, the
--- modified instance (after evacuation), the score of that solution,
--- and the new secondary node index.
-evacOneNodeInner :: AlgorithmOptions
-                 -> Node.List         -- ^ Cluster node list
-                 -> Instance.Instance -- ^ Instance being evacuated
-                 -> Gdx               -- ^ The group index of the instance
-                 -> (Ndx -> IMove)    -- ^ Operation constructor
-                 -> EvacInnerState    -- ^ Current best solution
-                 -> Ndx               -- ^ Node we're evaluating as target
-                 -> EvacInnerState    -- ^ New best solution
-evacOneNodeInner opts nl inst gdx op_fn accu ndx =
-  case applyMoveEx (algIgnoreSoftErrors opts) nl inst (op_fn ndx) of
-    Bad fm -> let fail_msg = " Node " ++ Container.nameOf nl ndx ++
-                             " failed: " ++ show fm ++ ";"
-              in either (Left . (++ fail_msg)) Right accu
-    Ok (nl', inst', _, _) ->
-      let nodes = Container.elems nl'
-          -- The fromJust below is ugly (it can fail nastily), but
-          -- at this point we should have any internal mismatches,
-          -- and adding a monad here would be quite involved
-          grpnodes = fromJust (gdx `lookup` Node.computeGroups nodes)
-          new_cv = compCVNodes grpnodes
-          new_accu = Right (nl', inst', new_cv, ndx)
-      in case accu of
-           Left _ -> new_accu
-           Right (_, _, old_cv, _) ->
-             if old_cv < new_cv
-               then accu
-               else new_accu
-
--- | Compute result of changing all nodes of a DRBD instance.
---
--- Given the target primary and secondary node (which might be in a
--- different group or not), this function will 'execute' all the
--- required steps and assuming all operations succceed, will return
--- the modified node and instance lists, the opcodes needed for this
--- and the new group score.
-evacDrbdAllInner :: AlgorithmOptions
-                 -> Node.List         -- ^ Cluster node list
-                 -> Instance.List     -- ^ Cluster instance list
-                 -> Instance.Instance -- ^ The instance to be moved
-                 -> Gdx               -- ^ The target group index
-                                      -- (which can differ from the
-                                      -- current group of the
-                                      -- instance)
-                 -> (Ndx, Ndx)        -- ^ Tuple of new
-                                      -- primary\/secondary nodes
-                 -> Result (Node.List, Instance.List, [OpCodes.OpCode], Score)
-evacDrbdAllInner opts nl il inst gdx (t_pdx, t_sdx) = do
-  let primary = Container.find (Instance.pNode inst) nl
-      idx = Instance.idx inst
-      apMove = applyMoveEx $ algIgnoreSoftErrors opts
-  -- if the primary is offline, then we first failover
-  (nl1, inst1, ops1) <-
-    if Node.offline primary
-      then do
-        (nl', inst', _, _) <-
-          annotateResult "Failing over to the secondary" .
-          opToResult $ apMove nl inst Failover
-        return (nl', inst', [Failover])
-      else return (nl, inst, [])
-  let (o1, o2, o3) = (ReplaceSecondary t_pdx,
-                      Failover,
-                      ReplaceSecondary t_sdx)
-  -- we now need to execute a replace secondary to the future
-  -- primary node
-  (nl2, inst2, _, _) <-
-    annotateResult "Changing secondary to new primary" .
-    opToResult $
-    apMove nl1 inst1 o1
-  let ops2 = o1:ops1
-  -- we now execute another failover, the primary stays fixed now
-  (nl3, inst3, _, _) <- annotateResult "Failing over to new primary" .
-                        opToResult $ apMove nl2 inst2 o2
-  let ops3 = o2:ops2
-  -- and finally another replace secondary, to the final secondary
-  (nl4, inst4, _, _) <-
-    annotateResult "Changing secondary to final secondary" .
-    opToResult $
-    apMove nl3 inst3 o3
-  let ops4 = o3:ops3
-      il' = Container.add idx inst4 il
-      ops = concatMap (iMoveToJob nl4 il' idx) $ reverse ops4
-  let nodes = Container.elems nl4
-      -- The fromJust below is ugly (it can fail nastily), but
-      -- at this point we should have any internal mismatches,
-      -- and adding a monad here would be quite involved
-      grpnodes = fromJust (gdx `lookup` Node.computeGroups nodes)
-      new_cv = compCVNodes grpnodes
-  return (nl4, il', ops, new_cv)
-
--- | Computes the nodes in a given group which are available for
--- allocation.
-availableGroupNodes :: [(Gdx, [Ndx])] -- ^ Group index/node index assoc list
-                    -> IntSet.IntSet  -- ^ Nodes that are excluded
-                    -> Gdx            -- ^ The group for which we
-                                      -- query the nodes
-                    -> Result [Ndx]   -- ^ List of available node indices
-availableGroupNodes group_nodes excl_ndx gdx = do
-  local_nodes <- maybe (Bad $ "Can't find group with index " ++ show gdx)
-                 Ok (lookup gdx group_nodes)
-  let avail_nodes = filter (not . flip IntSet.member excl_ndx) local_nodes
-  return avail_nodes
-
--- | Updates the evac solution with the results of an instance
--- evacuation.
-updateEvacSolution :: (Node.List, Instance.List, EvacSolution)
-                   -> Idx
-                   -> Result (Node.List, Instance.List, [OpCodes.OpCode])
-                   -> (Node.List, Instance.List, EvacSolution)
-updateEvacSolution (nl, il, es) idx (Bad msg) =
-  (nl, il, es { esFailed = (idx, msg):esFailed es})
-updateEvacSolution (_, _, es) idx (Ok (nl, il, opcodes)) =
-  (nl, il, es { esMoved = new_elem:esMoved es
-              , esOpCodes = opcodes:esOpCodes es })
-    where inst = Container.find idx il
-          new_elem = (idx,
-                      instancePriGroup nl inst,
-                      Instance.allNodes inst)
-
--- | Node-evacuation IAllocator mode main function.
-tryNodeEvac :: AlgorithmOptions
-            -> Group.List    -- ^ The cluster groups
-            -> Node.List     -- ^ The node list (cluster-wide, not per group)
-            -> Instance.List -- ^ Instance list (cluster-wide)
-            -> EvacMode      -- ^ The evacuation mode
-            -> [Idx]         -- ^ List of instance (indices) to be evacuated
-            -> Result (Node.List, Instance.List, EvacSolution)
-tryNodeEvac opts _ ini_nl ini_il mode idxs =
-  let evac_ndx = nodesToEvacuate ini_il mode idxs
-      offline = map Node.idx . filter Node.offline $ Container.elems ini_nl
-      excl_ndx = foldl' (flip IntSet.insert) evac_ndx offline
-      group_ndx = map (\(gdx, (nl, _)) -> (gdx, map Node.idx
-                                           (Container.elems nl))) $
-                  splitCluster ini_nl ini_il
-      (fin_nl, fin_il, esol) =
-        foldl' (\state@(nl, il, _) inst ->
-                  let gdx = instancePriGroup nl inst
-                      pdx = Instance.pNode inst in
-                  updateEvacSolution state (Instance.idx inst) $
-                  availableGroupNodes group_ndx
-                    (IntSet.insert pdx excl_ndx) gdx >>=
-                      nodeEvacInstance opts nl il mode inst gdx
-               )
-        (ini_nl, ini_il, emptyEvacSolution)
-        (map (`Container.find` ini_il) idxs)
-  in return (fin_nl, fin_il, reverseEvacSolution esol)
+
 
 -- | Change-group IAllocator mode main function.
 --
@@ -1694,86 +1128,6 @@ printInsts nl il =
       isnum = False:False:False:False:False:repeat True
   in printTable "" header (map helper sil) isnum
 
--- | Shows statistics for a given node list.
-printStats :: String -> Node.List -> String
-printStats lp nl =
-  let dcvs = compDetailedCV $ Container.elems nl
-      (weights, names) = unzip detailedCVInfo
-      hd = zip3 (weights ++ repeat 1) (names ++ repeat "unknown") dcvs
-      header = [ "Field", "Value", "Weight" ]
-      formatted = map (\(w, h, val) ->
-                         [ h
-                         , printf "%.8f" val
-                         , printf "x%.2f" w
-                         ]) hd
-  in printTable lp header formatted $ False:repeat True
-
--- | Convert a placement into a list of OpCodes (basically a job).
-iMoveToJob :: Node.List        -- ^ The node list; only used for node
-                               -- names, so any version is good
-                               -- (before or after the operation)
-           -> Instance.List    -- ^ The instance list; also used for
-                               -- names only
-           -> Idx              -- ^ The index of the instance being
-                               -- moved
-           -> IMove            -- ^ The actual move to be described
-           -> [OpCodes.OpCode] -- ^ The list of opcodes equivalent to
-                               -- the given move
-iMoveToJob nl il idx move =
-  let inst = Container.find idx il
-      iname = Instance.name inst
-      lookNode  n = case mkNonEmpty (Container.nameOf nl n) of
-                      -- FIXME: convert htools codebase to non-empty strings
-                      Bad msg -> error $ "Empty node name for idx " ++
-                                 show n ++ ": " ++ msg ++ "??"
-                      Ok ne -> Just ne
-      opF' = OpCodes.OpInstanceMigrate
-              { OpCodes.opInstanceName        = iname
-              , OpCodes.opInstanceUuid        = Nothing
-              , OpCodes.opMigrationMode       = Nothing -- default
-              , OpCodes.opOldLiveMode         = Nothing -- default as well
-              , OpCodes.opTargetNode          = Nothing -- this is drbd
-              , OpCodes.opTargetNodeUuid      = Nothing
-              , OpCodes.opAllowRuntimeChanges = False
-              , OpCodes.opIgnoreIpolicy       = False
-              , OpCodes.opMigrationCleanup    = False
-              , OpCodes.opIallocator          = Nothing
-              , OpCodes.opAllowFailover       = True
-              , OpCodes.opIgnoreHvversions    = True
-              }
-      opFA n = opF { OpCodes.opTargetNode = lookNode n } -- not drbd
-      opFforced =
-        OpCodes.OpInstanceFailover
-          { OpCodes.opInstanceName        = iname
-          , OpCodes.opInstanceUuid        = Nothing
-          , OpCodes.opShutdownTimeout     =
-              fromJust $ mkNonNegative C.defaultShutdownTimeout
-          , OpCodes.opIgnoreConsistency = False
-          , OpCodes.opTargetNode = Nothing
-          , OpCodes.opTargetNodeUuid = Nothing
-          , OpCodes.opIgnoreIpolicy = False
-          , OpCodes.opIallocator = Nothing
-          , OpCodes.opMigrationCleanup = False
-          }
-      opF = if Instance.forthcoming inst then opFforced else opF'
-      opR n = OpCodes.OpInstanceReplaceDisks
-                { OpCodes.opInstanceName     = iname
-                , OpCodes.opInstanceUuid     = Nothing
-                , OpCodes.opEarlyRelease     = False
-                , OpCodes.opIgnoreIpolicy    = False
-                , OpCodes.opReplaceDisksMode = OpCodes.ReplaceNewSecondary
-                , OpCodes.opReplaceDisksList = []
-                , OpCodes.opRemoteNode       = lookNode n
-                , OpCodes.opRemoteNodeUuid   = Nothing
-                , OpCodes.opIallocator       = Nothing
-                }
-  in case move of
-       Failover -> [ opF ]
-       FailoverToAny np -> [ opFA np ]
-       ReplacePrimary np -> [ opF, opR np, opF ]
-       ReplaceSecondary ns -> [ opR ns ]
-       ReplaceAndFailover np -> [ opR np, opF ]
-       FailoverAndReplace ns -> [ opF, opR ns ]
 
 -- * Node group functions
 
@@ -1792,47 +1146,8 @@ instanceGroup nl i =
                   show pgroup ++ ", secondary " ++ show sgroup)
        else return pgroup
 
--- | Computes the group of an instance per the primary node.
-instancePriGroup :: Node.List -> Instance.Instance -> Gdx
-instancePriGroup nl i =
-  let pnode = Container.find (Instance.pNode i) nl
-  in  Node.group pnode
-
 -- | Compute the list of badly allocated instances (split across node
 -- groups).
 findSplitInstances :: Node.List -> Instance.List -> [Instance.Instance]
 findSplitInstances nl =
   filter (not . isOk . instanceGroup nl) . Container.elems
-
--- | Splits a cluster into the component node groups.
-splitCluster :: Node.List -> Instance.List ->
-                [(Gdx, (Node.List, Instance.List))]
-splitCluster nl il =
-  let ngroups = Node.computeGroups (Container.elems nl)
-  in map (\(gdx, nodes) ->
-           let nidxs = map Node.idx nodes
-               nodes' = zip nidxs nodes
-               instances = Container.filter ((`elem` nidxs) . Instance.pNode) il
-           in (gdx, (Container.fromList nodes', instances))) ngroups
-
--- | Compute the list of nodes that are to be evacuated, given a list
--- of instances and an evacuation mode.
-nodesToEvacuate :: Instance.List -- ^ The cluster-wide instance list
-                -> EvacMode      -- ^ The evacuation mode we're using
-                -> [Idx]         -- ^ List of instance indices being evacuated
-                -> IntSet.IntSet -- ^ Set of node indices
-nodesToEvacuate il mode =
-  IntSet.delete Node.noSecondary .
-  foldl' (\ns idx ->
-            let i = Container.find idx il
-                pdx = Instance.pNode i
-                sdx = Instance.sNode i
-                dt = Instance.diskTemplate i
-                withSecondary = case dt of
-                                  DTDrbd8 -> IntSet.insert sdx ns
-                                  _ -> ns
-            in case mode of
-                 ChangePrimary   -> IntSet.insert pdx ns
-                 ChangeSecondary -> withSecondary
-                 ChangeAll       -> IntSet.insert pdx withSecondary
-         ) IntSet.empty
diff --git a/src/Ganeti/HTools/Cluster/Evacuate.hs b/src/Ganeti/HTools/Cluster/Evacuate.hs
new file mode 100644 (file)
index 0000000..74e1a84
--- /dev/null
@@ -0,0 +1,411 @@
+{-| Implementation of node evacuation
+
+-}
+
+{-
+
+Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+-}
+
+module Ganeti.HTools.Cluster.Evacuate
+  ( EvacSolution(..)
+  , nodeEvacInstance
+  , tryNodeEvac
+  , emptyEvacSolution
+  , updateEvacSolution
+  , reverseEvacSolution
+  ) where
+
+import qualified Data.IntSet as IntSet
+import Data.List (foldl')
+import Data.Maybe (fromJust)
+
+import Ganeti.BasicTypes
+import Ganeti.HTools.AlgorithmParams (AlgorithmOptions(..))
+import Ganeti.HTools.Cluster.Metrics (compCVNodes)
+import Ganeti.HTools.Cluster.Moves (applyMoveEx)
+import Ganeti.HTools.Cluster.Utils ( splitCluster, iMoveToJob
+                                   , instancePriGroup, availableGroupNodes)
+import qualified Ganeti.HTools.Container as Container
+import qualified Ganeti.HTools.Group as Group
+import qualified Ganeti.HTools.Instance as Instance
+import qualified Ganeti.HTools.Node as Node
+import Ganeti.HTools.Types
+import qualified Ganeti.OpCodes as OpCodes
+import Ganeti.Types
+
+-- | Node evacuation/group change iallocator result type. This result
+-- type consists of actual opcodes (a restricted subset) that are
+-- transmitted back to Ganeti.
+data EvacSolution = EvacSolution
+  { esMoved   :: [(Idx, Gdx, [Ndx])]  -- ^ Instances moved successfully
+  , esFailed  :: [(Idx, String)]      -- ^ Instances which were not
+                                      -- relocated
+  , esOpCodes :: [[OpCodes.OpCode]]   -- ^ List of jobs
+  } deriving (Show)
+
+-- | The empty evac solution.
+emptyEvacSolution :: EvacSolution
+emptyEvacSolution = EvacSolution { esMoved = []
+                                 , esFailed = []
+                                 , esOpCodes = []
+                                 }
+
+-- | Reverses an evacuation solution.
+--
+-- Rationale: we always concat the results to the top of the lists, so
+-- for proper jobset execution, we should reverse all lists.
+reverseEvacSolution :: EvacSolution -> EvacSolution
+reverseEvacSolution (EvacSolution f m o) =
+  EvacSolution (reverse f) (reverse m) (reverse o)
+
+-- | A simple type for the running solution of evacuations.
+type EvacInnerState =
+  Either String (Node.List, Instance.Instance, Score, Ndx)
+
+-- | Function which fails if the requested mode is change secondary.
+--
+-- This is useful since except DRBD, no other disk template can
+-- execute change secondary; thus, we can just call this function
+-- instead of always checking for secondary mode. After the call to
+-- this function, whatever mode we have is just a primary change.
+failOnSecondaryChange :: (Monad m) => EvacMode -> DiskTemplate -> m ()
+failOnSecondaryChange ChangeSecondary dt =
+  fail $ "Instances with disk template '" ++ diskTemplateToRaw dt ++
+         "' can't execute change secondary"
+failOnSecondaryChange _ _ = return ()
+
+
+-- | Inner fold function for changing one node of an instance.
+--
+-- Depending on the instance disk template, this will either change
+-- the secondary (for DRBD) or the primary node (for shared
+-- storage). However, the operation is generic otherwise.
+--
+-- The running solution is either a @Left String@, which means we
+-- don't have yet a working solution, or a @Right (...)@, which
+-- represents a valid solution; it holds the modified node list, the
+-- modified instance (after evacuation), the score of that solution,
+-- and the new secondary node index.
+evacOneNodeInner :: AlgorithmOptions
+                 -> Node.List         -- ^ Cluster node list
+                 -> Instance.Instance -- ^ Instance being evacuated
+                 -> Gdx               -- ^ The group index of the instance
+                 -> (Ndx -> IMove)    -- ^ Operation constructor
+                 -> EvacInnerState    -- ^ Current best solution
+                 -> Ndx               -- ^ Node we're evaluating as target
+                 -> EvacInnerState    -- ^ New best solution
+evacOneNodeInner opts nl inst gdx op_fn accu ndx =
+  case applyMoveEx (algIgnoreSoftErrors opts) nl inst (op_fn ndx) of
+    Bad fm -> let fail_msg = " Node " ++ Container.nameOf nl ndx ++
+                             " failed: " ++ show fm ++ ";"
+              in either (Left . (++ fail_msg)) Right accu
+    Ok (nl', inst', _, _) ->
+      let nodes = Container.elems nl'
+          -- The fromJust below is ugly (it can fail nastily), but
+          -- at this point we should have any internal mismatches,
+          -- and adding a monad here would be quite involved
+          grpnodes = fromJust (gdx `lookup` Node.computeGroups nodes)
+          new_cv = compCVNodes grpnodes
+          new_accu = Right (nl', inst', new_cv, ndx)
+      in case accu of
+           Left _ -> new_accu
+           Right (_, _, old_cv, _) ->
+             if old_cv < new_cv
+               then accu
+               else new_accu
+
+-- | Generic function for changing one node of an instance.
+--
+-- This is similar to 'nodeEvacInstance' but will be used in a few of
+-- its sub-patterns. It folds the inner function 'evacOneNodeInner'
+-- over the list of available nodes, which results in the best choice
+-- for relocation.
+evacOneNodeOnly :: AlgorithmOptions
+                -> Node.List         -- ^ The node list (cluster-wide)
+                -> Instance.List     -- ^ Instance list (cluster-wide)
+                -> Instance.Instance -- ^ The instance to be evacuated
+                -> Gdx               -- ^ The group we're targetting
+                -> [Ndx]             -- ^ The list of available nodes
+                                      -- for allocation
+                -> Result (Node.List, Instance.List, [OpCodes.OpCode])
+evacOneNodeOnly opts nl il inst gdx avail_nodes = do
+  op_fn <- case Instance.mirrorType inst of
+             MirrorNone -> Bad "Can't relocate/evacuate non-mirrored instances"
+             MirrorInternal -> Ok ReplaceSecondary
+             MirrorExternal -> Ok FailoverToAny
+  (nl', inst', _, ndx) <- annotateResult "Can't find any good node" .
+                          eitherToResult $
+                          foldl' (evacOneNodeInner opts nl inst gdx op_fn)
+                          (Left "") avail_nodes
+  let idx = Instance.idx inst
+      il' = Container.add idx inst' il
+      ops = iMoveToJob nl' il' idx (op_fn ndx)
+  return (nl', il', ops)
+
+-- | Compute result of changing all nodes of a DRBD instance.
+--
+-- Given the target primary and secondary node (which might be in a
+-- different group or not), this function will 'execute' all the
+-- required steps and assuming all operations succceed, will return
+-- the modified node and instance lists, the opcodes needed for this
+-- and the new group score.
+evacDrbdAllInner :: AlgorithmOptions
+                 -> Node.List         -- ^ Cluster node list
+                 -> Instance.List     -- ^ Cluster instance list
+                 -> Instance.Instance -- ^ The instance to be moved
+                 -> Gdx               -- ^ The target group index
+                                      -- (which can differ from the
+                                      -- current group of the
+                                      -- instance)
+                 -> (Ndx, Ndx)        -- ^ Tuple of new
+                                      -- primary\/secondary nodes
+                 -> Result (Node.List, Instance.List, [OpCodes.OpCode], Score)
+evacDrbdAllInner opts nl il inst gdx (t_pdx, t_sdx) = do
+  let primary = Container.find (Instance.pNode inst) nl
+      idx = Instance.idx inst
+      apMove = applyMoveEx $ algIgnoreSoftErrors opts
+  -- if the primary is offline, then we first failover
+  (nl1, inst1, ops1) <-
+    if Node.offline primary
+      then do
+        (nl', inst', _, _) <-
+          annotateResult "Failing over to the secondary" .
+          opToResult $ apMove nl inst Failover
+        return (nl', inst', [Failover])
+      else return (nl, inst, [])
+  let (o1, o2, o3) = (ReplaceSecondary t_pdx,
+                      Failover,
+                      ReplaceSecondary t_sdx)
+  -- we now need to execute a replace secondary to the future
+  -- primary node
+  (nl2, inst2, _, _) <-
+    annotateResult "Changing secondary to new primary" .
+    opToResult $
+    apMove nl1 inst1 o1
+  let ops2 = o1:ops1
+  -- we now execute another failover, the primary stays fixed now
+  (nl3, inst3, _, _) <- annotateResult "Failing over to new primary" .
+                        opToResult $ apMove nl2 inst2 o2
+  let ops3 = o2:ops2
+  -- and finally another replace secondary, to the final secondary
+  (nl4, inst4, _, _) <-
+    annotateResult "Changing secondary to final secondary" .
+    opToResult $
+    apMove nl3 inst3 o3
+  let ops4 = o3:ops3
+      il' = Container.add idx inst4 il
+      ops = concatMap (iMoveToJob nl4 il' idx) $ reverse ops4
+  let nodes = Container.elems nl4
+      -- The fromJust below is ugly (it can fail nastily), but
+      -- at this point we should have any internal mismatches,
+      -- and adding a monad here would be quite involved
+      grpnodes = fromJust (gdx `lookup` Node.computeGroups nodes)
+      new_cv = compCVNodes grpnodes
+  return (nl4, il', ops, new_cv)
+
+-- | Run evacuation for a single instance.
+--
+-- /Note:/ this function should correctly execute both intra-group
+-- evacuations (in all modes) and inter-group evacuations (in the
+-- 'ChangeAll' mode). Of course, this requires that the correct list
+-- of target nodes is passed.
+nodeEvacInstance :: AlgorithmOptions
+                 -> Node.List         -- ^ The node list (cluster-wide)
+                 -> Instance.List     -- ^ Instance list (cluster-wide)
+                 -> EvacMode          -- ^ The evacuation mode
+                 -> Instance.Instance -- ^ The instance to be evacuated
+                 -> Gdx               -- ^ The group we're targetting
+                 -> [Ndx]             -- ^ The list of available nodes
+                                      -- for allocation
+                 -> Result (Node.List, Instance.List, [OpCodes.OpCode])
+nodeEvacInstance opts nl il mode inst@(Instance.Instance
+                                    {Instance.diskTemplate = dt@DTDiskless})
+                 gdx avail_nodes =
+                   failOnSecondaryChange mode dt >>
+                   evacOneNodeOnly opts nl il inst gdx avail_nodes
+
+nodeEvacInstance _ _ _ _ (Instance.Instance
+                          {Instance.diskTemplate = DTPlain}) _ _ =
+                  fail "Instances of type plain cannot be relocated"
+
+nodeEvacInstance _ _ _ _ (Instance.Instance
+                          {Instance.diskTemplate = DTFile}) _ _ =
+                  fail "Instances of type file cannot be relocated"
+
+nodeEvacInstance opts nl il mode inst@(Instance.Instance
+                                    {Instance.diskTemplate = dt@DTSharedFile})
+                 gdx avail_nodes =
+                   failOnSecondaryChange mode dt >>
+                   evacOneNodeOnly opts nl il inst gdx avail_nodes
+
+nodeEvacInstance opts nl il mode inst@(Instance.Instance
+                                    {Instance.diskTemplate = dt@DTBlock})
+                 gdx avail_nodes =
+                   failOnSecondaryChange mode dt >>
+                   evacOneNodeOnly opts nl il inst gdx avail_nodes
+
+nodeEvacInstance opts nl il mode inst@(Instance.Instance
+                                    {Instance.diskTemplate = dt@DTRbd})
+                 gdx avail_nodes =
+                   failOnSecondaryChange mode dt >>
+                   evacOneNodeOnly opts nl il inst gdx avail_nodes
+
+nodeEvacInstance opts nl il mode inst@(Instance.Instance
+                                    {Instance.diskTemplate = dt@DTExt})
+                 gdx avail_nodes =
+                   failOnSecondaryChange mode dt >>
+                   evacOneNodeOnly opts nl il inst gdx avail_nodes
+
+nodeEvacInstance opts nl il mode inst@(Instance.Instance
+                                    {Instance.diskTemplate = dt@DTGluster})
+                 gdx avail_nodes =
+                   failOnSecondaryChange mode dt >>
+                   evacOneNodeOnly opts nl il inst gdx avail_nodes
+
+nodeEvacInstance opts nl il ChangePrimary
+                 inst@(Instance.Instance {Instance.diskTemplate = DTDrbd8})
+                 _ _ =
+  do
+    (nl', inst', _, _) <- opToResult
+                          $ applyMoveEx (algIgnoreSoftErrors opts) nl inst
+                            Failover
+    let idx = Instance.idx inst
+        il' = Container.add idx inst' il
+        ops = iMoveToJob nl' il' idx Failover
+    return (nl', il', ops)
+
+nodeEvacInstance opts nl il ChangeSecondary
+                 inst@(Instance.Instance {Instance.diskTemplate = DTDrbd8})
+                 gdx avail_nodes =
+  evacOneNodeOnly opts nl il inst gdx avail_nodes
+
+-- The algorithm for ChangeAll is as follows:
+--
+-- * generate all (primary, secondary) node pairs for the target groups
+-- * for each pair, execute the needed moves (r:s, f, r:s) and compute
+--   the final node list state and group score
+-- * select the best choice via a foldl that uses the same Either
+--   String solution as the ChangeSecondary mode
+nodeEvacInstance opts nl il ChangeAll
+                 inst@(Instance.Instance {Instance.diskTemplate = DTDrbd8})
+                 gdx avail_nodes =
+  do
+    let no_nodes = Left "no nodes available"
+        node_pairs = [(p,s) | p <- avail_nodes, s <- avail_nodes, p /= s]
+    (nl', il', ops, _) <-
+        annotateResult "Can't find any good nodes for relocation" .
+        eitherToResult $
+        foldl'
+        (\accu nodes -> case evacDrbdAllInner opts nl il inst gdx nodes of
+                          Bad msg ->
+                              case accu of
+                                Right _ -> accu
+                                -- we don't need more details (which
+                                -- nodes, etc.) as we only selected
+                                -- this group if we can allocate on
+                                -- it, hence failures will not
+                                -- propagate out of this fold loop
+                                Left _ -> Left $ "Allocation failed: " ++ msg
+                          Ok result@(_, _, _, new_cv) ->
+                              let new_accu = Right result in
+                              case accu of
+                                Left _ -> new_accu
+                                Right (_, _, _, old_cv) ->
+                                    if old_cv < new_cv
+                                    then accu
+                                    else new_accu
+        ) no_nodes node_pairs
+
+    return (nl', il', ops)
+
+-- | Updates the evac solution with the results of an instance
+-- evacuation.
+updateEvacSolution :: (Node.List, Instance.List, EvacSolution)
+                   -> Idx
+                   -> Result (Node.List, Instance.List, [OpCodes.OpCode])
+                   -> (Node.List, Instance.List, EvacSolution)
+updateEvacSolution (nl, il, es) idx (Bad msg) =
+  (nl, il, es { esFailed = (idx, msg):esFailed es})
+updateEvacSolution (_, _, es) idx (Ok (nl, il, opcodes)) =
+  (nl, il, es { esMoved = new_elem:esMoved es
+              , esOpCodes = opcodes:esOpCodes es })
+    where inst = Container.find idx il
+          new_elem = (idx,
+                      instancePriGroup nl inst,
+                      Instance.allNodes inst)
+
+-- | Compute the list of nodes that are to be evacuated, given a list
+-- of instances and an evacuation mode.
+nodesToEvacuate :: Instance.List -- ^ The cluster-wide instance list
+                -> EvacMode      -- ^ The evacuation mode we're using
+                -> [Idx]         -- ^ List of instance indices being evacuated
+                -> IntSet.IntSet -- ^ Set of node indices
+nodesToEvacuate il mode =
+  IntSet.delete Node.noSecondary .
+  foldl' (\ns idx ->
+            let i = Container.find idx il
+                pdx = Instance.pNode i
+                sdx = Instance.sNode i
+                dt = Instance.diskTemplate i
+                withSecondary = case dt of
+                                  DTDrbd8 -> IntSet.insert sdx ns
+                                  _ -> ns
+            in case mode of
+                 ChangePrimary   -> IntSet.insert pdx ns
+                 ChangeSecondary -> withSecondary
+                 ChangeAll       -> IntSet.insert pdx withSecondary
+         ) IntSet.empty
+
+-- | Node-evacuation IAllocator mode main function.
+tryNodeEvac :: AlgorithmOptions
+            -> Group.List    -- ^ The cluster groups
+            -> Node.List     -- ^ The node list (cluster-wide, not per group)
+            -> Instance.List -- ^ Instance list (cluster-wide)
+            -> EvacMode      -- ^ The evacuation mode
+            -> [Idx]         -- ^ List of instance (indices) to be evacuated
+            -> Result (Node.List, Instance.List, EvacSolution)
+tryNodeEvac opts _ ini_nl ini_il mode idxs =
+  let evac_ndx = nodesToEvacuate ini_il mode idxs
+      offline = map Node.idx . filter Node.offline $ Container.elems ini_nl
+      excl_ndx = foldl' (flip IntSet.insert) evac_ndx offline
+      group_ndx = map (\(gdx, (nl, _)) -> (gdx, map Node.idx
+                                           (Container.elems nl))) $
+                  splitCluster ini_nl ini_il
+      (fin_nl, fin_il, esol) =
+        foldl' (\state@(nl, il, _) inst ->
+                  let gdx = instancePriGroup nl inst
+                      pdx = Instance.pNode inst in
+                  updateEvacSolution state (Instance.idx inst) $
+                  availableGroupNodes group_ndx
+                    (IntSet.insert pdx excl_ndx) gdx >>=
+                      nodeEvacInstance opts nl il mode inst gdx
+               )
+        (ini_nl, ini_il, emptyEvacSolution)
+        (map (`Container.find` ini_il) idxs)
+  in return (fin_nl, fin_il, reverseEvacSolution esol)
diff --git a/src/Ganeti/HTools/Cluster/Metrics.hs b/src/Ganeti/HTools/Cluster/Metrics.hs
new file mode 100644 (file)
index 0000000..2d909ad
--- /dev/null
@@ -0,0 +1,221 @@
+{-| Implementation of the cluster metric
+
+-}
+
+{-
+
+Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+-}
+
+module Ganeti.HTools.Cluster.Metrics
+  ( compCV
+  , compCVfromStats
+  , compCVNodes
+  , compClusterStatistics
+  , updateClusterStatisticsTwice
+  , optimalCVScore
+  , printStats
+  ) where
+
+import Control.Monad (guard)
+import Data.List (partition, transpose)
+import Data.Maybe (fromMaybe)
+import Text.Printf (printf)
+
+import qualified Ganeti.HTools.Container as Container
+import qualified Ganeti.HTools.Node as Node
+import qualified Ganeti.HTools.PeerMap as P
+import Ganeti.HTools.Types
+import Ganeti.Utils (printTable)
+import Ganeti.Utils.Statistics
+
+-- | Coefficient for the total reserved memory in the cluster metric. We
+-- use a (local) constant here, as it is also used in the computation of
+-- the best possible cluster score.
+reservedMemRtotalCoeff :: Double
+reservedMemRtotalCoeff = 0.25
+
+-- | The names and weights of the individual elements in the CV list, together
+-- with their statistical accumulation function and a bit to decide whether it
+-- is a statistics for online nodes.
+detailedCVInfoExt :: [((Double, String), ([Double] -> Statistics, Bool))]
+detailedCVInfoExt = [ ((0.5,  "free_mem_cv"), (getStdDevStatistics, True))
+                    , ((0.5,  "free_disk_cv"), (getStdDevStatistics, True))
+                    , ((1,  "n1_cnt"), (getSumStatistics, True))
+                    , ((1,  "reserved_mem_cv"), (getStdDevStatistics, True))
+                    , ((4,  "offline_all_cnt"), (getSumStatistics, False))
+                    , ((16, "offline_pri_cnt"), (getSumStatistics, False))
+                    , ( (0.5,  "vcpu_ratio_cv")
+                      , (getStdDevStatistics, True))
+                    , ((1,  "cpu_load_cv"), (getStdDevStatistics, True))
+                    , ((1,  "mem_load_cv"), (getStdDevStatistics, True))
+                    , ((1,  "disk_load_cv"), (getStdDevStatistics, True))
+                    , ((1,  "net_load_cv"), (getStdDevStatistics, True))
+                    , ((2,  "pri_tags_score"), (getSumStatistics, True))
+                    , ((0.5,  "spindles_cv"), (getStdDevStatistics, True))
+                    , ((0.5,  "free_mem_cv_forth"), (getStdDevStatistics, True))
+                    , ( (0.5,  "free_disk_cv_forth")
+                      , (getStdDevStatistics, True))
+                    , ( (0.5,  "vcpu_ratio_cv_forth")
+                      , (getStdDevStatistics, True))
+                    , ((0.5,  "spindles_cv_forth"), (getStdDevStatistics, True))
+                    , ((1,  "location_score"), (getSumStatistics, True))
+                    , ( (reservedMemRtotalCoeff,  "reserved_mem_rtotal")
+                      , (getSumStatistics, True))
+                    ]
+
+-- | Compute the lower bound of the cluster score, i.e., the sum of the minimal
+-- values for all cluster score values that are not 0 on a perfectly balanced
+-- cluster.
+optimalCVScore :: Node.List -> Double
+optimalCVScore nodelist = fromMaybe 0 $ do
+  let nodes = Container.elems nodelist
+  guard $ length nodes > 1
+  let nodeMems = map Node.tMem nodes
+      totalMem = sum nodeMems
+      totalMemOneLessNode = totalMem - maximum nodeMems
+  guard $ totalMemOneLessNode > 0
+  let totalDrbdMem = fromIntegral . sum $ map (P.sumElems . Node.peers) nodes
+      optimalUsage = totalDrbdMem / totalMem
+      optimalUsageOneLessNode = totalDrbdMem / totalMemOneLessNode
+      relativeReserved = optimalUsageOneLessNode - optimalUsage
+  return $ reservedMemRtotalCoeff * relativeReserved
+
+-- | The names and weights of the individual elements in the CV list.
+detailedCVInfo :: [(Double, String)]
+detailedCVInfo = map fst detailedCVInfoExt
+
+-- | Holds the weights used by 'compCVNodes' for each metric.
+detailedCVWeights :: [Double]
+detailedCVWeights = map fst detailedCVInfo
+
+-- | The aggregation functions for the weights
+detailedCVAggregation :: [([Double] -> Statistics, Bool)]
+detailedCVAggregation = map snd detailedCVInfoExt
+
+-- | The bit vector describing which parts of the statistics are
+-- for online nodes.
+detailedCVOnlineStatus :: [Bool]
+detailedCVOnlineStatus = map snd detailedCVAggregation
+
+-- | Compute statistical measures of a single node.
+compDetailedCVNode :: Node.Node -> [Double]
+compDetailedCVNode node =
+  let mem = Node.pMem node
+      memF = Node.pMemForth node
+      dsk = Node.pDsk node
+      dskF = Node.pDskForth node
+      n1 = fromIntegral
+           $ if Node.failN1 node
+               then length (Node.sList node) + length (Node.pList node)
+               else 0
+      res = Node.pRem node
+      ipri = fromIntegral . length $ Node.pList node
+      isec = fromIntegral . length $ Node.sList node
+      ioff = ipri + isec
+      cpu = Node.pCpuEff node
+      cpuF = Node.pCpuEffForth node
+      DynUtil c1 m1 d1 nn1 = Node.utilLoad node
+      DynUtil c2 m2 d2 nn2 = Node.utilPool node
+      (c_load, m_load, d_load, n_load) = (c1/c2, m1/m2, d1/d2, nn1/nn2)
+      pri_tags = fromIntegral $ Node.conflictingPrimaries node
+      spindles = Node.instSpindles node / Node.hiSpindles node
+      spindlesF = Node.instSpindlesForth node / Node.hiSpindles node
+      location_score = fromIntegral $ Node.locationScore node
+  in [ mem, dsk, n1, res, ioff, ipri, cpu
+     , c_load, m_load, d_load, n_load
+     , pri_tags, spindles
+     , memF, dskF, cpuF, spindlesF
+     , location_score
+     , res
+     ]
+
+-- | Compute the statistics of a cluster.
+compClusterStatistics :: [Node.Node] -> [Statistics]
+compClusterStatistics all_nodes =
+  let (offline, nodes) = partition Node.offline all_nodes
+      offline_values = transpose (map compDetailedCVNode offline)
+                       ++ repeat []
+      -- transpose of an empty list is empty and not k times the empty list, as
+      -- would be the transpose of a 0 x k matrix
+      online_values = transpose $ map compDetailedCVNode nodes
+      aggregate (f, True) (onNodes, _) = f onNodes
+      aggregate (f, False) (_, offNodes) = f offNodes
+  in zipWith aggregate detailedCVAggregation
+       $ zip online_values offline_values
+
+-- | Update a cluster statistics by replacing the contribution of one
+-- node by that of another.
+updateClusterStatistics :: [Statistics]
+                           -> (Node.Node, Node.Node) -> [Statistics]
+updateClusterStatistics stats (old, new) =
+  let update = zip (compDetailedCVNode old) (compDetailedCVNode new)
+      online = not $ Node.offline old
+      updateStat forOnline stat upd = if forOnline == online
+                                        then updateStatistics stat upd
+                                        else stat
+  in zipWith3 updateStat detailedCVOnlineStatus stats update
+
+-- | Update a cluster statistics twice.
+updateClusterStatisticsTwice :: [Statistics]
+                                -> (Node.Node, Node.Node)
+                                -> (Node.Node, Node.Node)
+                                -> [Statistics]
+updateClusterStatisticsTwice s a =
+  updateClusterStatistics (updateClusterStatistics s a)
+
+-- | Compute cluster statistics
+compDetailedCV :: [Node.Node] -> [Double]
+compDetailedCV = map getStatisticValue . compClusterStatistics
+
+-- | Compute the cluster score from its statistics
+compCVfromStats :: [Statistics] -> Double
+compCVfromStats = sum . zipWith (*) detailedCVWeights . map getStatisticValue
+
+-- | Compute the /total/ variance.
+compCVNodes :: [Node.Node] -> Double
+compCVNodes = sum . zipWith (*) detailedCVWeights . compDetailedCV
+
+-- | Wrapper over 'compCVNodes' for callers that have a 'Node.List'.
+compCV :: Node.List -> Double
+compCV = compCVNodes . Container.elems
+
+-- | Shows statistics for a given node list.
+printStats :: String -> Node.List -> String
+printStats lp nl =
+  let dcvs = compDetailedCV $ Container.elems nl
+      (weights, names) = unzip detailedCVInfo
+      hd = zip3 (weights ++ repeat 1) (names ++ repeat "unknown") dcvs
+      header = [ "Field", "Value", "Weight" ]
+      formatted = map (\(w, h, val) ->
+                         [ h
+                         , printf "%.8f" val
+                         , printf "x%.2f" w
+                         ]) hd
+  in printTable lp header formatted $ False:repeat True
+
diff --git a/src/Ganeti/HTools/Cluster/Moves.hs b/src/Ganeti/HTools/Cluster/Moves.hs
new file mode 100644 (file)
index 0000000..5fca893
--- /dev/null
@@ -0,0 +1,189 @@
+{-| Implementation of instance moves in a cluster.
+
+-}
+
+{-
+
+Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+-}
+
+module Ganeti.HTools.Cluster.Moves
+  ( applyMoveEx
+  , setInstanceLocationScore
+  , move
+  ) where
+
+import qualified Data.Set as Set
+
+import Ganeti.HTools.Types
+import qualified Ganeti.HTools.Container as Container
+import qualified Ganeti.HTools.Instance as Instance
+import qualified Ganeti.HTools.Node as Node
+
+-- | Extracts the node pairs for an instance. This can fail if the
+-- instance is single-homed. FIXME: this needs to be improved,
+-- together with the general enhancement for handling non-DRBD moves.
+instanceNodes :: Node.List -> Instance.Instance ->
+                 (Ndx, Ndx, Node.Node, Node.Node)
+instanceNodes nl inst =
+  let old_pdx = Instance.pNode inst
+      old_sdx = Instance.sNode inst
+      old_p = Container.find old_pdx nl
+      old_s = Container.find old_sdx nl
+  in (old_pdx, old_sdx, old_p, old_s)
+
+-- | Sets the location score of an instance, given its primary
+-- and secondary node.
+setInstanceLocationScore :: Instance.Instance -- ^ the original instance
+                         -> Node.Node -- ^ the primary node of the instance
+                         -> Node.Node -- ^ the secondary node of the instance
+                         -> Instance.Instance -- ^ the instance with the
+                                              -- location score updated
+setInstanceLocationScore t p s =
+  t { Instance.locationScore =
+         Set.size $ Node.locationTags p `Set.intersection` Node.locationTags s }
+
+-- | Applies an instance move to a given node list and instance.
+applyMoveEx :: Bool -- ^ whether to ignore soft errors
+               -> Node.List -> Instance.Instance
+               -> IMove -> OpResult (Node.List, Instance.Instance, Ndx, Ndx)
+-- Failover (f)
+applyMoveEx force nl inst Failover =
+  let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
+      int_p = Node.removePri old_p inst
+      int_s = Node.removeSec old_s inst
+      new_nl = do -- OpResult
+        Node.checkMigration old_p old_s
+        new_p <- Node.addPriEx (Node.offline old_p || force) int_s inst
+        new_s <- Node.addSecExEx (Node.offline old_p) (Node.offline old_p)
+                   int_p inst old_sdx
+        let new_inst = Instance.setBoth inst old_sdx old_pdx
+        return (Container.addTwo old_pdx new_s old_sdx new_p nl,
+                new_inst, old_sdx, old_pdx)
+  in new_nl
+
+-- Failover to any (fa)
+applyMoveEx force nl inst (FailoverToAny new_pdx) = do
+  let (old_pdx, old_sdx, old_pnode, _) = instanceNodes nl inst
+      new_pnode = Container.find new_pdx nl
+      force_failover = Node.offline old_pnode || force
+  Node.checkMigration old_pnode new_pnode
+  new_pnode' <- Node.addPriEx force_failover new_pnode inst
+  let old_pnode' = Node.removePri old_pnode inst
+      inst' = Instance.setPri inst new_pdx
+      nl' = Container.addTwo old_pdx old_pnode' new_pdx new_pnode' nl
+  return (nl', inst', new_pdx, old_sdx)
+
+-- Replace the primary (f:, r:np, f)
+applyMoveEx force nl inst (ReplacePrimary new_pdx) =
+  let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
+      tgt_n = Container.find new_pdx nl
+      int_p = Node.removePri old_p inst
+      int_s = Node.removeSec old_s inst
+      new_inst = Instance.setPri (setInstanceLocationScore inst tgt_n int_s)
+                 new_pdx
+      force_p = Node.offline old_p || force
+      new_nl = do -- OpResult
+                  -- check that the current secondary can host the instance
+                  -- during the migration
+        Node.checkMigration old_p old_s
+        Node.checkMigration old_s tgt_n
+        tmp_s <- Node.addPriEx force_p int_s new_inst
+        let tmp_s' = Node.removePri tmp_s new_inst
+        new_p <- Node.addPriEx force_p tgt_n new_inst
+        new_s <- Node.addSecEx force_p tmp_s' new_inst new_pdx
+        return (Container.add new_pdx new_p $
+                Container.addTwo old_pdx int_p old_sdx new_s nl,
+                new_inst, new_pdx, old_sdx)
+  in new_nl
+
+-- Replace the secondary (r:ns)
+applyMoveEx force nl inst (ReplaceSecondary new_sdx) =
+  let old_pdx = Instance.pNode inst
+      old_sdx = Instance.sNode inst
+      old_s = Container.find old_sdx nl
+      tgt_n = Container.find new_sdx nl
+      pnode = Container.find old_pdx nl
+      pnode' = Node.removePri pnode inst
+      int_s = Node.removeSec old_s inst
+      force_s = Node.offline old_s || force
+      new_inst = Instance.setSec (setInstanceLocationScore inst pnode tgt_n)
+                 new_sdx
+      new_nl = do
+        new_s <- Node.addSecEx force_s tgt_n new_inst old_pdx
+        pnode'' <- Node.addPriEx True pnode' new_inst
+        return (Container.add old_pdx pnode'' $
+                Container.addTwo new_sdx new_s old_sdx int_s nl,
+                new_inst, old_pdx, new_sdx)
+  in new_nl
+
+-- Replace the secondary and failover (r:np, f)
+applyMoveEx force nl inst (ReplaceAndFailover new_pdx) =
+  let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
+      tgt_n = Container.find new_pdx nl
+      int_p = Node.removePri old_p inst
+      int_s = Node.removeSec old_s inst
+      new_inst = Instance.setBoth (setInstanceLocationScore inst tgt_n int_p)
+                 new_pdx old_pdx
+      force_s = Node.offline old_s || force
+      new_nl = do -- OpResult
+        Node.checkMigration old_p tgt_n
+        new_p <- Node.addPriEx force tgt_n new_inst
+        new_s <- Node.addSecEx force_s int_p new_inst new_pdx
+        return (Container.add new_pdx new_p $
+                Container.addTwo old_pdx new_s old_sdx int_s nl,
+                new_inst, new_pdx, old_pdx)
+  in new_nl
+
+-- Failver and replace the secondary (f, r:ns)
+applyMoveEx force nl inst (FailoverAndReplace new_sdx) =
+  let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
+      tgt_n = Container.find new_sdx nl
+      int_p = Node.removePri old_p inst
+      int_s = Node.removeSec old_s inst
+      force_p = Node.offline old_p || force
+      new_inst = Instance.setBoth (setInstanceLocationScore inst int_s tgt_n)
+                 old_sdx new_sdx
+      new_nl = do -- OpResult
+        Node.checkMigration old_p old_s
+        new_p <- Node.addPriEx force_p int_s new_inst
+        new_s <- Node.addSecEx force_p tgt_n new_inst old_sdx
+        return (Container.add new_sdx new_s $
+                Container.addTwo old_sdx new_p old_pdx int_p nl,
+                new_inst, old_sdx, new_sdx)
+  in new_nl
+
+-- | Apply a move to an instance, ignoring soft errors. This is a
+-- variant of `applyMoveEx True` suitable for folding.
+move :: (Node.List, Instance.List)
+        -> (Idx, IMove)
+        -> OpResult (Node.List, Instance.List)
+move (nl, il) (idx, mv) = do
+  let inst = Container.find idx il
+  (nl', inst', _, _) <- applyMoveEx True nl inst mv
+  return (nl', Container.add idx inst' il)
diff --git a/src/Ganeti/HTools/Cluster/Utils.hs b/src/Ganeti/HTools/Cluster/Utils.hs
new file mode 100644 (file)
index 0000000..11e5038
--- /dev/null
@@ -0,0 +1,150 @@
+{-| Utility functions for cluster operations
+
+-}
+
+{-
+
+Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+-}
+
+module Ganeti.HTools.Cluster.Utils
+  ( splitCluster
+  , iMoveToJob
+  , instancePriGroup
+  , availableGroupNodes
+  ) where
+
+import Data.Maybe (fromJust)
+import qualified Data.IntSet as IntSet
+
+import Ganeti.BasicTypes
+import qualified Ganeti.Constants as C
+import qualified Ganeti.HTools.Container as Container
+import qualified Ganeti.HTools.Instance as Instance
+import qualified Ganeti.HTools.Node as Node
+import Ganeti.HTools.Types
+import qualified Ganeti.OpCodes as OpCodes
+import Ganeti.Types (mkNonEmpty, mkNonNegative)
+
+-- | Splits a cluster into the component node groups.
+splitCluster :: Node.List -> Instance.List ->
+                [(Gdx, (Node.List, Instance.List))]
+splitCluster nl il =
+  let ngroups = Node.computeGroups (Container.elems nl)
+  in map (\(gdx, nodes) ->
+           let nidxs = map Node.idx nodes
+               nodes' = zip nidxs nodes
+               instances = Container.filter ((`elem` nidxs) . Instance.pNode) il
+           in (gdx, (Container.fromList nodes', instances))) ngroups
+
+-- | Convert a placement into a list of OpCodes (basically a job).
+iMoveToJob :: Node.List        -- ^ The node list; only used for node
+                               -- names, so any version is good
+                               -- (before or after the operation)
+           -> Instance.List    -- ^ The instance list; also used for
+                               -- names only
+           -> Idx              -- ^ The index of the instance being
+                               -- moved
+           -> IMove            -- ^ The actual move to be described
+           -> [OpCodes.OpCode] -- ^ The list of opcodes equivalent to
+                               -- the given move
+iMoveToJob nl il idx move =
+  let inst = Container.find idx il
+      iname = Instance.name inst
+      lookNode  n = case mkNonEmpty (Container.nameOf nl n) of
+                      -- FIXME: convert htools codebase to non-empty strings
+                      Bad msg -> error $ "Empty node name for idx " ++
+                                 show n ++ ": " ++ msg ++ "??"
+                      Ok ne -> Just ne
+      opF' = OpCodes.OpInstanceMigrate
+              { OpCodes.opInstanceName        = iname
+              , OpCodes.opInstanceUuid        = Nothing
+              , OpCodes.opMigrationMode       = Nothing -- default
+              , OpCodes.opOldLiveMode         = Nothing -- default as well
+              , OpCodes.opTargetNode          = Nothing -- this is drbd
+              , OpCodes.opTargetNodeUuid      = Nothing
+              , OpCodes.opAllowRuntimeChanges = False
+              , OpCodes.opIgnoreIpolicy       = False
+              , OpCodes.opMigrationCleanup    = False
+              , OpCodes.opIallocator          = Nothing
+              , OpCodes.opAllowFailover       = True
+              , OpCodes.opIgnoreHvversions    = True
+              }
+      opFA n = opF { OpCodes.opTargetNode = lookNode n } -- not drbd
+      opFforced =
+        OpCodes.OpInstanceFailover
+          { OpCodes.opInstanceName        = iname
+          , OpCodes.opInstanceUuid        = Nothing
+          , OpCodes.opShutdownTimeout     =
+              fromJust $ mkNonNegative C.defaultShutdownTimeout
+          , OpCodes.opIgnoreConsistency = False
+          , OpCodes.opTargetNode = Nothing
+          , OpCodes.opTargetNodeUuid = Nothing
+          , OpCodes.opIgnoreIpolicy = False
+          , OpCodes.opIallocator = Nothing
+          , OpCodes.opMigrationCleanup = False
+          }
+      opF = if Instance.forthcoming inst then opFforced else opF'
+      opR n = OpCodes.OpInstanceReplaceDisks
+                { OpCodes.opInstanceName     = iname
+                , OpCodes.opInstanceUuid     = Nothing
+                , OpCodes.opEarlyRelease     = False
+                , OpCodes.opIgnoreIpolicy    = False
+                , OpCodes.opReplaceDisksMode = OpCodes.ReplaceNewSecondary
+                , OpCodes.opReplaceDisksList = []
+                , OpCodes.opRemoteNode       = lookNode n
+                , OpCodes.opRemoteNodeUuid   = Nothing
+                , OpCodes.opIallocator       = Nothing
+                }
+  in case move of
+       Failover -> [ opF ]
+       FailoverToAny np -> [ opFA np ]
+       ReplacePrimary np -> [ opF, opR np, opF ]
+       ReplaceSecondary ns -> [ opR ns ]
+       ReplaceAndFailover np -> [ opR np, opF ]
+       FailoverAndReplace ns -> [ opF, opR ns ]
+
+-- | Computes the group of an instance per the primary node.
+instancePriGroup :: Node.List -> Instance.Instance -> Gdx
+instancePriGroup nl i =
+  let pnode = Container.find (Instance.pNode i) nl
+  in  Node.group pnode
+
+-- | Computes the nodes in a given group which are available for
+-- allocation.
+availableGroupNodes :: [(Gdx, [Ndx])] -- ^ Group index/node index assoc list
+                    -> IntSet.IntSet  -- ^ Nodes that are excluded
+                    -> Gdx            -- ^ The group for which we
+                                      -- query the nodes
+                    -> Result [Ndx]   -- ^ List of available node indices
+availableGroupNodes group_nodes excl_ndx gdx = do
+  local_nodes <- maybe (Bad $ "Can't find group with index " ++ show gdx)
+                 Ok (lookup gdx group_nodes)
+  let avail_nodes = filter (not . flip IntSet.member excl_ndx) local_nodes
+  return avail_nodes
+
diff --git a/src/Ganeti/HTools/Dedicated.hs b/src/Ganeti/HTools/Dedicated.hs
new file mode 100644 (file)
index 0000000..8059766
--- /dev/null
@@ -0,0 +1,257 @@
+{-| Implementation of special handling of dedicated clusters.
+
+-}
+
+{-
+
+Copyright (C) 2014 Google Inc.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+-}
+
+module Ganeti.HTools.Dedicated
+  ( isDedicated
+  , testInstances
+  , allocationVector
+  , Metric
+  , lostAllocationsMetric
+  , allocateOnSingle
+  , allocateOnPair
+  , findAllocation
+  , runDedicatedAllocation
+  ) where
+
+import Control.Applicative (liftA2, (<$>))
+import Control.Arrow ((&&&))
+import Control.Monad (unless, liftM, foldM)
+import qualified Data.Foldable as F
+import Data.Function (on)
+import qualified Data.IntMap as IntMap
+import qualified Data.IntSet as IntSet
+import Data.List (sortBy, intercalate)
+
+import Ganeti.BasicTypes (iterateOk, Result, failError)
+import qualified Ganeti.HTools.AlgorithmParams as Alg
+import qualified Ganeti.HTools.Backend.IAlloc as IAlloc
+import qualified Ganeti.HTools.Cluster as Cluster
+import qualified Ganeti.HTools.Cluster.Utils as ClusterUtils
+import qualified Ganeti.HTools.Container as Container
+import qualified Ganeti.HTools.Group as Group
+import qualified Ganeti.HTools.Instance as Instance
+import qualified Ganeti.HTools.Loader as Loader
+import qualified Ganeti.HTools.Node as Node
+import qualified Ganeti.HTools.Types as T
+
+-- | Given a cluster description and maybe a group name, decide
+-- if that group, or all allocatable groups if no group is given,
+-- is dedicated.
+isDedicated :: Loader.ClusterData -> Maybe String -> Bool
+isDedicated cdata maybeGroup =
+  let groups =
+        IntMap.keysSet
+        . IntMap.filter (maybe ((/=) T.AllocUnallocable . Group.allocPolicy)
+                               (\name -> (==) name . Group.name) maybeGroup)
+        $ Loader.cdGroups cdata
+  in F.all (liftA2 (||) Node.exclStorage
+            $ not  . (`IntSet.member` groups) . Node.group)
+     $ Loader.cdNodes cdata
+
+-- | Given a specification interval, create an instance minimally fitting
+-- into that interval. In other words create an instance from the lower bounds
+-- of the specified interval.
+minimallyCompliantInstance :: T.ISpec -> Instance.Instance
+minimallyCompliantInstance spec =
+  Instance.create "minimalspecinstance"
+    (T.iSpecMemorySize spec)
+    (T.iSpecDiskSize spec)
+    []
+    (T.iSpecCpuCount spec)
+    T.Running [] False Node.noSecondary Node.noSecondary T.DTPlain
+    (T.iSpecSpindleUse spec)
+    [] False
+
+-- | From an instance policy get the list of test instances, in correct order,
+-- for which the allocation count has to be determined for the lost allocations
+-- metrics.
+testInstances :: T.IPolicy -> [Instance.Instance]
+testInstances =
+  map minimallyCompliantInstance
+  . sortBy (flip compare `on` T.iSpecDiskSize)
+  . map T.minMaxISpecsMinSpec
+  . T.iPolicyMinMaxISpecs
+
+-- | Given the test instances, compute the allocations vector of a node
+allocationVector :: [Instance.Instance] -> Node.Node -> [Int]
+allocationVector insts node =
+  map (\ inst -> length $ iterateOk (`Node.addPri` inst) node) insts
+
+-- | The metric do be used in dedicated allocation.
+type Metric = ([Int], Int)
+
+-- | Given the test instances and an instance to be placed, compute
+-- the lost allocations metrics for that node, together with the
+-- modified node. Return Bad if it is not possible to place the
+-- instance on that node.
+lostAllocationsMetric :: Alg.AlgorithmOptions
+                      -> [Instance.Instance]
+                      -> Instance.Instance
+                      -> Node.Node
+                      -> T.OpResult (Metric, Node.Node)
+lostAllocationsMetric opts insts inst node = do
+  let allocVec = allocationVector insts
+      before = allocVec node
+      force = Alg.algIgnoreSoftErrors opts
+  node' <- Node.addPriEx force node inst
+  let after = allocVec node'
+      disk = Node.fDsk node'
+  return ((zipWith (-) before after, disk), node')
+
+-- | Allocate an instance on a given node.
+allocateOnSingle :: Alg.AlgorithmOptions
+                 -> Node.List -> Instance.Instance -> T.Ndx
+                 -> T.OpResult (Node.GenericAllocElement Metric)
+allocateOnSingle opts nl inst new_pdx = do
+  let primary = Container.find new_pdx nl
+      policy = Node.iPolicy primary
+      testInst = testInstances policy
+      excl = Node.exclStorage primary
+      new_inst = Instance.setBoth inst new_pdx Node.noSecondary
+  Instance.instMatchesPolicy inst policy excl
+  (metrics, new_p) <- lostAllocationsMetric opts testInst inst primary
+  let new_nl = Container.add new_pdx new_p nl
+  return (new_nl, new_inst, [new_p], metrics)
+
+-- | Allocate an instance on a given pair of nodes.
+allocateOnPair :: Alg.AlgorithmOptions
+               -> Node.List
+               -> Instance.Instance
+               -> T.Ndx
+               -> T.Ndx
+               -> T.OpResult (Node.GenericAllocElement Metric)
+allocateOnPair opts nl inst pdx sdx = do
+  let primary = Container.find pdx nl
+      secondary = Container.find sdx nl
+      policy = Node.iPolicy primary
+      testInst = testInstances policy
+      inst' = Instance.setBoth inst pdx sdx
+  Instance.instMatchesPolicy inst policy (Node.exclStorage primary)
+  ((lAllP, dskP), primary') <- lostAllocationsMetric opts testInst inst' primary
+  secondary' <- Node.addSec secondary inst' pdx
+  let lAllS =  zipWith (-) (allocationVector testInst secondary)
+                           (allocationVector testInst secondary')
+      dskS = Node.fDsk secondary'
+      metric = (zipWith (+) lAllP lAllS, dskP + dskS)
+      nl' = Container.addTwo pdx primary' sdx secondary' nl
+  return (nl', inst', [primary', secondary'], metric)
+
+-- | Find an allocation for an instance on a group.
+findAllocation :: Alg.AlgorithmOptions
+               -> Group.List
+               -> Node.List
+               -> T.Gdx
+               -> Instance.Instance
+               -> Int
+               -> Result (Cluster.GenericAllocSolution Metric, [String])
+findAllocation opts mggl mgnl gdx inst count = do
+  let nl = Container.filter ((== gdx) . Node.group) mgnl
+      group = Container.find gdx mggl
+  unless (Cluster.hasRequiredNetworks group inst) . failError
+         $ "The group " ++ Group.name group ++ " is not connected to\
+           \ a network required by instance " ++ Instance.name inst
+  allocNodes <- Cluster.genAllocNodes mggl nl count False
+  solution <- case allocNodes of
+    (Right []) -> fail "Not enough online nodes"
+    (Right pairs) ->
+      let sols = foldl Cluster.sumAllocs Cluster.emptyAllocSolution
+                   $ map (\(p, ss) -> foldl
+                           (\cstate ->
+                             Cluster.concatAllocs cstate
+                             . allocateOnPair opts nl inst p)
+                           Cluster.emptyAllocSolution ss)
+                     pairs
+       in return $ Cluster.genericAnnotateSolution show sols
+    (Left []) -> fail "No online nodes"
+    (Left nodes) ->
+      let sols = foldl (\cstate ->
+                          Cluster.concatAllocs cstate
+                          . allocateOnSingle opts nl inst)
+                       Cluster.emptyAllocSolution nodes
+      in return $ Cluster.genericAnnotateSolution show sols
+  return (solution, Cluster.solutionDescription (group, return solution))
+
+-- | Find an allocation in a suitable group.
+findMGAllocation :: Alg.AlgorithmOptions
+                 -> Group.List
+                 -> Node.List
+                 -> Instance.List
+                 -> Instance.Instance
+                 -> Int
+                 -> Result (Cluster.GenericAllocSolution Metric)
+findMGAllocation opts gl nl il inst count = do
+  let groups_by_idx = ClusterUtils.splitCluster nl il
+      genSol (gdx, (nl', _)) =
+        liftM fst $ findAllocation opts gl nl' gdx inst count
+      sols = map (flip Container.find gl . fst &&& genSol) groups_by_idx
+      goodSols = Cluster.sortMGResults $ Cluster.filterMGResults sols
+      all_msgs = concatMap Cluster.solutionDescription sols
+  case goodSols of
+    [] -> fail $ intercalate ", " all_msgs
+    (final_group, final_sol):_ ->
+      let sel_msg = "Selected group: " ++ Group.name final_group
+      in return $ final_sol { Cluster.asLog = sel_msg : all_msgs }
+
+-- | Handle allocation requests in the dedicated scenario.
+runDedicatedAllocation :: Alg.AlgorithmOptions
+                       -> Loader.Request
+                       -> (Maybe (Node.List, Instance.List), String)
+runDedicatedAllocation opts request =
+  let Loader.Request rqtype (Loader.ClusterData gl nl il _ _) = request
+      allocresult =
+        case rqtype of
+          Loader.Allocate inst (Cluster.AllocDetails count (Just gn)) -> do
+            gdx <- Group.idx <$> Container.findByName gl gn
+            (solution, msgs) <- findAllocation opts gl nl gdx inst count
+            IAlloc.formatAllocate il $ solution { Cluster.asLog = msgs }
+          Loader.Allocate inst (Cluster.AllocDetails count Nothing) ->
+            findMGAllocation opts gl nl il inst count
+              >>= IAlloc.formatAllocate il
+          Loader.MultiAllocate insts ->
+            IAlloc.formatMultiAlloc =<< foldM
+              (\(nl', il', res)
+                (inst, Cluster.AllocDetails count maybeGroup) -> do
+                  ares <- maybe (findMGAllocation opts gl nl' il' inst count)
+                            (\gn -> do
+                               gdx <- Group.idx <$> Container.findByName gl gn
+                               liftM fst
+                                 $ findAllocation opts gl nl gdx inst count)
+                          maybeGroup
+                  let sol = Cluster.asSolution ares
+                      nl'' = Cluster.extractNl nl' sol
+                      il'' = Cluster.updateIl il' sol
+                  return (nl'', il'', (inst, ares):res))
+               (nl, il, []) insts
+          _ -> fail "Dedicated Allocation only for proper allocation requests"
+  in IAlloc.formatIAllocResult allocresult
index acb5b5e..56e2e80 100644 (file)
@@ -1,5 +1,3 @@
-{-# LANGUAGE BangPatterns #-}
-
 {-| External data loader.
 
 This module holds the external data loading, and thus is the only one
@@ -42,43 +40,29 @@ module Ganeti.HTools.ExtLoader
   ( loadExternalData
   , commonSuffix
   , maybeSaveData
-  , queryAllMonDDCs
-  , pMonDData
   ) where
 
 import Control.Monad
+import Control.Monad.Writer (runWriterT)
 import Control.Exception
-import Data.Maybe (isJust, fromJust, catMaybes)
-import Network.Curl
+import Data.Maybe (isJust, fromJust)
+import Data.Monoid (getAll)
 import System.FilePath
 import System.IO
 import System.Time (getClockTime)
 import Text.Printf (hPrintf)
 
-import qualified Text.JSON as J
-import qualified Data.Map as Map
-import qualified Data.List as L
-
-import qualified Ganeti.Constants as C
-import qualified Ganeti.DataCollectors.CPUload as CPUload
-import qualified Ganeti.HTools.Container as Container
+import Ganeti.BasicTypes
 import qualified Ganeti.HTools.Backend.Luxi as Luxi
 import qualified Ganeti.HTools.Backend.Rapi as Rapi
 import qualified Ganeti.HTools.Backend.Simu as Simu
 import qualified Ganeti.HTools.Backend.Text as Text
 import qualified Ganeti.HTools.Backend.IAlloc as IAlloc
-import qualified Ganeti.HTools.Node as Node
-import qualified Ganeti.HTools.Instance as Instance
+import qualified Ganeti.HTools.Backend.MonD as MonD
+import Ganeti.HTools.CLI
 import Ganeti.HTools.Loader (mergeData, checkData, ClusterData(..)
                             , commonSuffix, clearDynU)
-
-import Ganeti.BasicTypes
-import Ganeti.Cpu.Types
-import Ganeti.DataCollectors.Types hiding (DataCollector(..))
 import Ganeti.HTools.Types
-import Ganeti.HTools.CLI
-import Ganeti.JSON
-import Ganeti.Logging (logWarning)
 import Ganeti.Utils (sepSplit, tryRead, exitIfBad, exitWhen)
 
 -- | Error beautifier.
@@ -142,7 +126,11 @@ loadExternalData opts = do
       ldresult = input_data >>= (if ignoreDynU then clearDynU else return)
                             >>= mergeData eff_u exTags selInsts exInsts now
   cdata <- exitIfBad "failed to load data, aborting" ldresult
-  cdata' <- if optMonD opts then queryAllMonDDCs cdata opts else return cdata
+  (cdata', ok) <- runWriterT $ if optMonD opts
+                                 then MonD.queryAllMonDDCs cdata opts
+                                 else return cdata
+  exitWhen (optMonDExitMissing opts && not (getAll ok))
+      "Not all required data available"
   let (fix_msgs, nl) = checkData (cdNodes cdata') (cdInstances cdata')
 
   unless (optVerbose opts == 0) $ maybeShowWarnings fix_msgs
@@ -162,152 +150,3 @@ maybeSaveData (Just path) ext msg cdata = do
   writeFile out_path adata
   hPrintf stderr "The cluster state %s has been written to file '%s'\n"
           msg out_path
-
--- | Type describing a data collector basic information.
-data DataCollector = DataCollector
-  { dName     :: String           -- ^ Name of the data collector
-  , dCategory :: Maybe DCCategory -- ^ The name of the category
-  }
-
--- | The actual data types for MonD's Data Collectors.
-data Report = CPUavgloadReport CPUavgload
-
--- | The list of Data Collectors used by hail and hbal.
-collectors :: Options -> [DataCollector]
-collectors opts =
-  if optIgnoreDynu opts
-    then []
-    else [ DataCollector CPUload.dcName CPUload.dcCategory ]
-
--- | MonDs Data parsed by a mock file. Representing (node name, list of reports
--- produced by MonDs Data Collectors).
-type MonDData = (String, [DCReport])
-
--- | A map storing MonDs data.
-type MapMonDData = Map.Map String [DCReport]
-
--- | Parse MonD data file contents.
-pMonDData :: String -> Result [MonDData]
-pMonDData input =
-  loadJSArray "Parsing MonD's answer" input >>=
-  mapM (pMonDN . J.fromJSObject)
-
--- | Parse a node's JSON record.
-pMonDN :: JSRecord -> Result MonDData
-pMonDN a = do
-  node <- tryFromObj "Parsing node's name" a "node"
-  reports <- tryFromObj "Parsing node's reports" a "reports"
-  return (node, reports)
-
--- | Query all MonDs for all Data Collector.
-queryAllMonDDCs :: ClusterData -> Options -> IO ClusterData
-queryAllMonDDCs cdata opts = do
-  map_mDD <-
-    case optMonDFile opts of
-      Nothing -> return Nothing
-      Just fp -> do
-        monDData_contents <- readFile fp
-        monDData <- exitIfBad "can't parse MonD data"
-                    . pMonDData $ monDData_contents
-        return . Just $ Map.fromList monDData
-  let (ClusterData _ nl il _ _) = cdata
-  (nl', il') <- foldM (queryAllMonDs map_mDD) (nl, il) (collectors opts)
-  return $ cdata {cdNodes = nl', cdInstances = il'}
-
--- | Query all MonDs for a single Data Collector.
-queryAllMonDs :: Maybe MapMonDData -> (Node.List, Instance.List)
-                 -> DataCollector -> IO (Node.List, Instance.List)
-queryAllMonDs m (nl, il) dc = do
-  elems <- mapM (queryAMonD m dc) (Container.elems nl)
-  let elems' = catMaybes elems
-  if length elems == length elems'
-    then
-      let il' = foldl updateUtilData il elems'
-          nl' = zip (Container.keys nl) elems'
-      in return (Container.fromList nl', il')
-    else do
-      logWarning $ "Didn't receive an answer by all MonDs, " ++ dName dc
-                   ++ "'s data will be ignored."
-      return (nl,il)
-
--- | Query a specified MonD for a Data Collector.
-fromCurl :: DataCollector -> Node.Node -> IO (Maybe DCReport)
-fromCurl dc node = do
-  (code, !body) <-  curlGetString (prepareUrl dc node) []
-  case code of
-    CurlOK ->
-      case J.decodeStrict body :: J.Result DCReport of
-        J.Ok r -> return $ Just r
-        J.Error _ -> return Nothing
-    _ -> do
-      logWarning $ "Failed to contact node's " ++ Node.name node
-                   ++ " MonD for DC " ++ dName dc
-      return Nothing
-
--- | Return the data from correct combination of a Data Collector
--- and a DCReport.
-mkReport :: DataCollector -> Maybe DCReport -> Maybe Report
-mkReport dc dcr =
-  case dcr of
-    Nothing -> Nothing
-    Just dcr' ->
-      case () of
-           _ | CPUload.dcName == dName dc ->
-                 case fromJVal (dcReportData dcr') :: Result CPUavgload of
-                   Ok cav -> Just $ CPUavgloadReport cav
-                   Bad _ -> Nothing
-             | otherwise -> Nothing
-
--- | Get data report for the specified Data Collector and Node from the map.
-fromFile :: DataCollector -> Node.Node -> MapMonDData -> Maybe DCReport
-fromFile dc node m =
-  let matchDCName dcr = dName dc == dcReportName dcr
-  in maybe Nothing (L.find matchDCName) $ Map.lookup (Node.name node) m
-
--- | Query a MonD for a single Data Collector.
-queryAMonD :: Maybe MapMonDData -> DataCollector -> Node.Node
-              -> IO (Maybe Node.Node)
-queryAMonD m dc node = do
-  dcReport <-
-    case m of
-      Nothing -> fromCurl dc node
-      Just m' -> return $ fromFile dc node m'
-  case mkReport dc dcReport of
-    Nothing -> return Nothing
-    Just report ->
-      case report of
-        CPUavgloadReport cav ->
-          let ct = cavCpuTotal cav
-              du = Node.utilLoad node
-              du' = du {cpuWeight = ct}
-          in return $ Just node {Node.utilLoad = du'}
-
--- | Update utilization data.
-updateUtilData :: Instance.List -> Node.Node -> Instance.List
-updateUtilData il node =
-  let ct = cpuWeight (Node.utilLoad node)
-      n_uCpu = Node.uCpu node
-      upd inst =
-        if Node.idx node == Instance.pNode inst
-          then
-            let i_vcpus = Instance.vcpus inst
-                i_util = ct / fromIntegral n_uCpu * fromIntegral i_vcpus
-                i_du = Instance.util inst
-                i_du' = i_du {cpuWeight = i_util}
-            in inst {Instance.util = i_du'}
-          else inst
-  in Container.map upd il
-
--- | Prepare url to query a single collector.
-prepareUrl :: DataCollector -> Node.Node -> URLString
-prepareUrl dc node =
-  Node.name node ++ ":" ++ show C.defaultMondPort ++ "/"
-  ++ show C.mondLatestApiVersion ++ "/report/" ++
-  getDCCName (dCategory dc) ++ "/" ++ dName dc
-
--- | Get Category Name.
-getDCCName :: Maybe DCCategory -> String
-getDCCName dcc =
-  case dcc of
-    Nothing -> "default"
-    Just c -> getCategoryName c
diff --git a/src/Ganeti/HTools/GlobalN1.hs b/src/Ganeti/HTools/GlobalN1.hs
new file mode 100644 (file)
index 0000000..581d22d
--- /dev/null
@@ -0,0 +1,85 @@
+{-| Implementation of global N+1 redundancy
+
+-}
+
+{-
+
+Copyright (C) 2015 Google Inc.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+-}
+
+module Ganeti.HTools.GlobalN1
+  ( canEvacuateNode
+  ) where
+
+import Control.Monad (foldM, foldM_)
+import Data.List (partition)
+
+import Ganeti.BasicTypes (isOk, Result)
+import Ganeti.HTools.AlgorithmParams (AlgorithmOptions(..), defaultOptions)
+import qualified Ganeti.HTools.Cluster.Evacuate as Evacuate
+import Ganeti.HTools.Cluster.Moves (move)
+import qualified Ganeti.HTools.Container as Container
+import qualified Ganeti.HTools.Instance as Instance
+import qualified Ganeti.HTools.Node as Node
+import Ganeti.HTools.Types ( IMove(Failover), Ndx, Gdx, Idx, opToResult)
+import Ganeti.Types ( DiskTemplate(DTDrbd8, DTPlain, DTFile)
+                    , EvacMode(ChangePrimary))
+
+-- | Foldable function describing how a non-DRBD instance
+-- is to be evacuated.
+evac :: Gdx -> [Ndx]
+     -> (Node.List, Instance.List) -> Idx -> Result (Node.List, Instance.List)
+evac gdx ndxs (nl, il) idx = do
+  let opts = defaultOptions { algIgnoreSoftErrors = True, algEvacMode = True }
+      inst = Container.find idx il
+  (nl', il', _) <- Evacuate.nodeEvacInstance opts nl il ChangePrimary inst
+                     gdx ndxs
+  return (nl', il')
+
+-- | Decide if a node can be evacuated, i.e., all DRBD instances
+-- failed over and all shared/external storage instances moved off
+-- to other nodes.
+canEvacuateNode :: (Node.List, Instance.List) -> Node.Node -> Bool
+canEvacuateNode (nl, il) n = isOk $ do
+  let (drbdIdxs, otherIdxs) = partition ((==) DTDrbd8
+                                         . Instance.diskTemplate
+                                         . flip Container.find il)
+                              $ Node.pList n
+      sharedIdxs = filter (not . (`elem` [DTPlain, DTFile])
+                           . Instance.diskTemplate
+                           . flip Container.find il) otherIdxs
+  -- failover all DRBD instances with primaries on n
+  (nl', il') <- opToResult
+                . foldM move (nl, il) $ map (flip (,) Failover) drbdIdxs
+  -- evacuate other instances
+  let grp = Node.group n
+      escapenodes = filter (/= Node.idx n)
+                    . map Node.idx
+                    . filter ((== grp) . Node.group)
+                    $ Container.elems nl'
+  foldM_ (evac grp escapenodes) (nl',il') sharedIdxs
index 10df2c5..e08cce0 100644 (file)
@@ -51,6 +51,7 @@ module Ganeti.HTools.Loader
   , RqType(..)
   , Request(..)
   , ClusterData(..)
+  , isAllocationRequest
   , emptyCluster
   ) where
 
@@ -66,6 +67,7 @@ import qualified Ganeti.HTools.Instance as Instance
 import qualified Ganeti.HTools.Node as Node
 import qualified Ganeti.HTools.Group as Group
 import qualified Ganeti.HTools.Cluster as Cluster
+import qualified Ganeti.HTools.Cluster.Moves as Moves
 
 import Ganeti.BasicTypes
 import qualified Ganeti.HTools.Tags as Tags
@@ -96,6 +98,21 @@ data RqType
 data Request = Request RqType ClusterData
                deriving (Show)
 
+-- | Decide whether a request asks to allocate new instances; if so, also
+-- return the desired node group, if a unique node group is specified.
+-- That is, return `Nothing` if the request is not an allocation request,
+-- `Just Nothing`, if it is an Allocation request, but there is no unique
+-- group specified, and return `Just (Just g)` if it is an allocation request
+-- uniquely requesting Group `g`.
+isAllocationRequest :: RqType -> Maybe (Maybe String)
+isAllocationRequest (Allocate _ (Cluster.AllocDetails _ grp)) = Just grp
+isAllocationRequest (MultiAllocate reqs) = Just $
+  case ordNub . catMaybes
+       $ map (\(_, Cluster.AllocDetails _ grp) -> grp) reqs of
+    [grp] -> Just grp
+    _ -> Nothing
+isAllocationRequest _ = Nothing
+
 -- | The cluster state.
 data ClusterData = ClusterData
   { cdGroups    :: Group.List    -- ^ The node group list
@@ -153,7 +170,7 @@ setLocationScore :: Node.List -> Instance.Instance -> Instance.Instance
 setLocationScore nl inst =
   let pnode = Container.find (Instance.pNode inst) nl
       snode = Container.find (Instance.sNode inst) nl
-  in Cluster.setInstanceLocationScore inst pnode snode
+  in Moves.setInstanceLocationScore inst pnode snode
 
 -- | For each instance, add its index to its primary and secondary nodes.
 fixNodes :: Node.List
index f47a45f..c4eca69 100644 (file)
@@ -92,6 +92,7 @@ module Ganeti.HTools.Node
   , list
   -- * Misc stuff
   , AssocList
+  , GenericAllocElement
   , AllocElement
   , noSecondary
   , computeGroups
@@ -246,8 +247,12 @@ type AssocList = [(T.Ndx, Node)]
 type List = Container.Container Node
 
 -- | A simple name for an allocation element (here just for logistic
+-- reasons), generic in the type of the metric.
+type GenericAllocElement a = (List, Instance.Instance, [Node], a)
+
+-- | A simple name for an allocation element (here just for logistic
 -- reasons).
-type AllocElement = (List, Instance.Instance, [Node], T.Score)
+type AllocElement = GenericAllocElement T.Score
 
 -- | Constant node index for a non-moveable instance.
 noSecondary :: T.Ndx
index 67e3050..c4b7a6f 100644 (file)
@@ -46,6 +46,7 @@ module Ganeti.HTools.PeerMap
   , add
   , remove
   , maxElem
+  , sumElems
   ) where
 
 import Data.Maybe (fromMaybe)
@@ -114,3 +115,7 @@ remove k ((x@(x', _)):xs) = if k == x'
 maxElem :: PeerMap -> Elem
 maxElem (x:_) = snd x
 maxElem _ = 0
+
+-- | Sum of all peers.
+sumElems :: PeerMap -> Elem
+sumElems = sum . map snd
index 6a90bb2..db1be29 100644 (file)
@@ -39,18 +39,20 @@ module Ganeti.HTools.Program.Hail
   ) where
 
 import Control.Monad
+import Control.Monad.Writer (runWriterT)
 import Data.Maybe (fromMaybe, isJust)
 import System.IO
 
 import qualified Ganeti.HTools.AlgorithmParams as Alg
 import qualified Ganeti.HTools.Cluster as Cluster
+import qualified Ganeti.HTools.Dedicated as Dedicated
 
 import Ganeti.Common
 import Ganeti.HTools.CLI
 import Ganeti.HTools.Backend.IAlloc
-import Ganeti.HTools.Loader (Request(..), ClusterData(..))
-import Ganeti.HTools.ExtLoader (maybeSaveData, loadExternalData
-                               , queryAllMonDDCs)
+import qualified Ganeti.HTools.Backend.MonD as MonD
+import Ganeti.HTools.Loader (Request(..), ClusterData(..), isAllocationRequest)
+import Ganeti.HTools.ExtLoader (maybeSaveData, loadExternalData)
 import Ganeti.Utils
 
 -- | Options list and functions.
@@ -65,6 +67,7 @@ options =
     , oIgnoreDyn
     , oIgnoreSoftErrors
     , oMonD
+    , oMonDXen
     ]
 
 -- | The list of arguments supported by the program.
@@ -85,8 +88,9 @@ wrapReadRequest opts args = do
       return $ Request rqt cdata
     else do
       let Request rqt cdata = r1
-      cdata' <-
-        if optMonD opts then queryAllMonDDCs cdata opts else return cdata
+      (cdata', _) <- runWriterT $ if optMonD opts
+                                    then MonD.queryAllMonDDCs cdata opts
+                                    else return cdata
       return $ Request rqt cdata'
 
 -- | Main function.
@@ -106,12 +110,22 @@ main opts args = do
   when (verbose > 2) .
        hPutStrLn stderr $ "Received cluster data: " ++ show cdata
 
+  let dedicatedAlloc = maybe False (Dedicated.isDedicated cdata)
+                       $ isAllocationRequest rq
+
+  when (verbose > 1 && dedicatedAlloc) $
+      hPutStrLn stderr "Allocation on a dedicated cluster;\
+                       \ using lost-allocations metrics."
+
   maybePrintNodes shownodes "Initial cluster"
        (Cluster.printNodes (cdNodes cdata))
 
   maybeSaveData savecluster "pre-ialloc" "before iallocator run" cdata
 
-  let (maybe_ni, resp) = runIAllocator (Alg.fromCLIOptions opts) request
+  let runAlloc = if dedicatedAlloc
+                   then Dedicated.runDedicatedAllocation
+                   else runIAllocator
+      (maybe_ni, resp) = runAlloc (Alg.fromCLIOptions opts) request
       (fin_nl, fin_il) = fromMaybe (cdNodes cdata, cdInstances cdata) maybe_ni
   putStrLn resp
 
index f8fa48d..084433a 100644 (file)
@@ -43,7 +43,7 @@ import Control.Arrow ((&&&))
 import Control.Lens (over)
 import Control.Monad
 import Data.List
-import Data.Maybe (isNothing)
+import Data.Maybe (isNothing, fromMaybe)
 import System.Exit
 import System.IO
 
@@ -52,6 +52,8 @@ import Text.Printf (printf)
 import Ganeti.HTools.AlgorithmParams (AlgorithmOptions(..), fromCLIOptions)
 import qualified Ganeti.HTools.Container as Container
 import qualified Ganeti.HTools.Cluster as Cluster
+import qualified Ganeti.HTools.Cluster.Metrics as Metrics
+import qualified Ganeti.HTools.Cluster.Utils as ClusterUtils
 import qualified Ganeti.HTools.Group as Group
 import qualified Ganeti.HTools.Node as Node
 import qualified Ganeti.HTools.Instance as Instance
@@ -86,6 +88,8 @@ options = do
     , luxi
     , oIAllocSrc
     , oExecJobs
+    , oFirstJobGroup
+    , oReason
     , oGroup
     , oMaxSolLength
     , oVerbose
@@ -104,6 +108,8 @@ options = do
     , oIgnoreDyn 
     , oMonD
     , oMonDDataFile
+    , oMonDExitMissing
+    , oMonDXen
     , oExTags
     , oExInst
     , oSaveCluster
@@ -116,10 +122,11 @@ arguments = []
 
 -- | Wraps an 'OpCode' in a 'MetaOpCode' while also adding a comment
 -- about what generated the opcode.
-annotateOpCode :: Timestamp -> Jobs.Annotator
-annotateOpCode ts =
+annotateOpCode :: Maybe String -> Timestamp -> Jobs.Annotator
+annotateOpCode reason ts =
   over (metaParamsL . opReasonL)
-      (++ [("hbal", "hbal " ++ version ++ " called", reasonTrailTimestamp ts)])
+      (++ [( "hbal", fromMaybe ("hbal " ++ version ++ " called") reason
+           , reasonTrailTimestamp ts)])
   . setOpComment ("rebalancing via hbal " ++ version)
   . wrapOpCode
 
@@ -187,7 +194,7 @@ maybeExecJobs opts ord_plc fin_nl il cmd_jobs =
             Just master -> do
               ts <- currentTimestamp
               let annotator = maybe id setOpPriority (optPriority opts) .
-                              annotateOpCode ts
+                              annotateOpCode (optReason opts) ts
               execWithCancel annotator master $
                 zip (map toOpcodes cmd_jobs) (map toDescr cmd_jobs))
     else return $ Ok ()
@@ -200,7 +207,7 @@ maybeExecJobs opts ord_plc fin_nl il cmd_jobs =
 selectGroup :: Options -> Group.List -> Node.List -> Instance.List
             -> IO (String, (Node.List, Instance.List))
 selectGroup opts gl nlf ilf = do
-  let ngroups = Cluster.splitCluster nlf ilf
+  let ngroups = ClusterUtils.splitCluster nlf ilf
   when (length ngroups > 1 && isNothing (optGroup opts)) $ do
     hPutStrLn stderr "Found multiple node groups:"
     mapM_ (hPutStrLn stderr . ("  " ++) . Group.name .
@@ -285,13 +292,14 @@ checkGroup force verbose gname nl il = do
            \ consider using the --ignore-soft-errors option."
 
 -- | Check that we actually need to rebalance.
-checkNeedRebalance :: Options -> Score -> IO ()
-checkNeedRebalance opts ini_cv = do
+checkNeedRebalance :: Options -> Score -> Score -> IO ()
+checkNeedRebalance opts ini_cv opt_cv = do
   let min_cv = optMinScore opts
-  when (ini_cv < min_cv) $ do
+  when (ini_cv - opt_cv < min_cv) $ do
          printf "Cluster is already well balanced (initial score %.6g,\n\
+                \optimum score due to N+1 reservations %.6g,\n\
                 \minimum score %.6g).\nNothing to do, exiting\n"
-                ini_cv min_cv:: IO ()
+                ini_cv opt_cv min_cv:: IO ()
          exitSuccess
 
 -- | Main function.
@@ -323,16 +331,17 @@ main opts args = do
 
   maybePrintNodes shownodes "Initial cluster" (Cluster.printNodes nl)
 
-  let ini_cv = Cluster.compCV nl
+  let ini_cv = Metrics.compCV nl
+      opt_cv = Metrics.optimalCVScore nl
       ini_tbl = Cluster.Table nl il ini_cv []
       min_cv = optMinScore opts
 
   if verbose > 2
     then printf "Initial coefficients: overall %.8f\n%s"
-           ini_cv (Cluster.printStats "  " nl)::IO ()
+           ini_cv (Metrics.printStats "  " nl)::IO ()
     else printf "Initial score: %.8f\n" ini_cv
 
-  checkNeedRebalance opts ini_cv
+  checkNeedRebalance opts ini_cv opt_cv
 
   putStrLn "Trying to minimize the CV..."
   let imlen = maximum . map (length . Instance.alias) $ Container.elems il
@@ -340,14 +349,14 @@ main opts args = do
 
   (fin_tbl, cmd_strs) <- iterateDepth True (fromCLIOptions opts) ini_tbl
                          (optMaxLength opts)
-                         nmlen imlen [] min_cv
+                         nmlen imlen [] (opt_cv + min_cv)
   let (Cluster.Table fin_nl fin_il fin_cv fin_plc) = fin_tbl
       ord_plc = reverse fin_plc
       sol_msg = case () of
                   _ | null fin_plc -> printf "No solution found\n"
                     | verbose > 2 ->
                         printf "Final coefficients:   overall %.8f\n%s"
-                        fin_cv (Cluster.printStats "  " fin_nl)
+                        fin_cv (Metrics.printStats "  " fin_nl)
                     | otherwise ->
                         printf "Cluster score improved from %.8f to %.8f\n"
                         ini_cv fin_cv ::String
@@ -357,9 +366,13 @@ main opts args = do
   unless (verbose < 1) $
          printf "Solution length=%d\n" (length ord_plc)
 
-  let cmd_jobs = Cluster.splitJobs cmd_strs
+  let cmd_jobs = (if optFirstJobGroup opts then take 1 else id)
+                 $ Cluster.splitJobs cmd_strs
 
-  maybeSaveCommands "Commands to run to reach the above solution:" opts
+  maybeSaveCommands (if optFirstJobGroup opts
+                        then "First set of jobs:"
+                        else "Commands to run to reach the above solution:")
+                    opts
     $ Cluster.formatCmds cmd_jobs
 
   maybeSaveData (optSaveCluster opts) "balanced" "after balancing"
index 1f06adf..a2251ff 100644 (file)
@@ -39,6 +39,7 @@ module Ganeti.HTools.Program.Hcheck
   ) where
 
 import Control.Monad
+import qualified Data.IntMap as IntMap
 import Data.List (transpose)
 import System.Exit
 import Text.Printf (printf)
@@ -46,6 +47,9 @@ import Text.Printf (printf)
 import Ganeti.HTools.AlgorithmParams (fromCLIOptions)
 import qualified Ganeti.HTools.Container as Container
 import qualified Ganeti.HTools.Cluster as Cluster
+import qualified Ganeti.HTools.Cluster.Metrics as Metrics
+import qualified Ganeti.HTools.Cluster.Utils as ClusterUtils
+import qualified Ganeti.HTools.GlobalN1 as GlobalN1
 import qualified Ganeti.HTools.Group as Group
 import qualified Ganeti.HTools.Node as Node
 import qualified Ganeti.HTools.Instance as Instance
@@ -67,6 +71,7 @@ options = do
     [ oDataFile
     , oDiskMoves
     , oDynuFile
+    , oIgnoreDyn
     , oEvacMode
     , oExInst
     , oExTags
@@ -86,6 +91,7 @@ options = do
     , oQuiet
     , oRapiMaster
     , oSelInst
+    , oNoCapacityChecks
     , oVerbose
     ]
 
@@ -112,20 +118,22 @@ htcPrefix :: String
 htcPrefix = "HCHECK"
 
 -- | Data showed both per group and per cluster.
-commonData :: [(String, String)]
-commonData =[ ("N1_FAIL", "Nodes not N+1 happy")
-            , ("CONFLICT_TAGS", "Nodes with conflicting instances")
-            , ("OFFLINE_PRI", "Instances having the primary node offline")
-            , ("OFFLINE_SEC", "Instances having a secondary node offline")
-            ]
+commonData :: Options -> [(String, String)]
+commonData opts =
+  [ ("N1_FAIL", "Nodes not N+1 happy")
+  , ("CONFLICT_TAGS", "Nodes with conflicting instances")
+  , ("OFFLINE_PRI", "Instances having the primary node offline")
+  , ("OFFLINE_SEC", "Instances having a secondary node offline")
+  ]
+  ++ [ ("GN1_FAIL", "Nodes not directly evacuateable")  | optCapacity opts ]
 
 -- | Data showed per group.
-groupData :: [(String, String)]
-groupData = commonData ++ [("SCORE", "Group score")]
+groupData :: Options -> [(String, String)]
+groupData opts = commonData opts ++ [("SCORE", "Group score")]
 
 -- | Data showed per cluster.
-clusterData :: [(String, String)]
-clusterData = commonData ++
+clusterData :: Options -> [(String, String)]
+clusterData opts = commonData opts  ++
               [ ("NEED_REBALANCE", "Cluster is not healthy") ]
 
 -- | Phase-specific prefix for machine readable version.
@@ -139,9 +147,9 @@ levelPrefix GroupLvl {} = "GROUP"
 levelPrefix ClusterLvl  = "CLUSTER"
 
 -- | Machine-readable keys to show depending on given level.
-keysData :: Level -> [String]
-keysData GroupLvl {} = map fst groupData
-keysData ClusterLvl  = map fst clusterData
+keysData :: Options -> Level -> [String]
+keysData opts GroupLvl {} = map fst $ groupData opts
+keysData opts ClusterLvl  = map fst $ clusterData opts
 
 -- | Description of phases for human readable version.
 phaseDescr :: Phase -> String
@@ -149,9 +157,9 @@ phaseDescr Initial = "initially"
 phaseDescr Rebalanced = "after rebalancing"
 
 -- | Description to show depending on given level.
-descrData :: Level -> [String]
-descrData GroupLvl {} = map snd groupData
-descrData ClusterLvl  = map snd clusterData
+descrData :: Options -> Level -> [String]
+descrData opts GroupLvl {} = map snd $ groupData opts
+descrData opts ClusterLvl  = map snd $ clusterData opts
 
 -- | Human readable prefix for statistics.
 phaseLevelDescr :: Phase -> Level -> String
@@ -189,20 +197,20 @@ prepareKey level@(GroupLvl idx) phase suffix =
   printf "%s_%s_%s_%s" (phasePrefix phase) (levelPrefix level) idx suffix
 
 -- | Print all the statistics for given level and phase.
-printStats :: Int            -- ^ Verbosity level
+printStats :: Options
            -> Bool           -- ^ If the output should be machine readable
            -> Level          -- ^ Level on which we are printing
            -> Phase          -- ^ Current phase of simulation
            -> [String]       -- ^ Values to print
            -> IO ()
-printStats _ True level phase values = do
-  let keys = map (prepareKey level phase) (keysData level)
+printStats opts True level phase values = do
+  let keys = map (prepareKey level phase) (keysData opts level)
   printKeysHTC $ zip keys values
 
-printStats verbose False level phase values = do
+printStats opts False level phase values = do
   let prefix = phaseLevelDescr phase level
-      descr = descrData level
-  unless (verbose < 1) $ do
+      descr = descrData opts level
+  unless (optVerbose opts < 1) $ do
     putStrLn ""
     putStr prefix
     mapM_ (uncurry (printf "    %s: %s\n")) (zip descr values)
@@ -223,17 +231,17 @@ prepareClusterValues machineread stats bstats =
   map show stats ++ map (printBool machineread) bstats
 
 -- | Print all the statistics on a group level.
-printGroupStats :: Int -> Bool -> Phase -> GroupStats -> IO ()
-printGroupStats verbose machineread phase ((grp, score), stats) = do
+printGroupStats :: Options -> Bool -> Phase -> GroupStats -> IO ()
+printGroupStats opts machineread phase ((grp, score), stats) = do
   let values = prepareGroupValues stats score
       extradata = extractGroupData machineread grp
-  printStats verbose machineread (GroupLvl extradata) phase values
+  printStats opts machineread (GroupLvl extradata) phase values
 
 -- | Print all the statistics on a cluster (global) level.
-printClusterStats :: Int -> Bool -> Phase -> [Int] -> Bool -> IO ()
-printClusterStats verbose machineread phase stats needhbal = do
+printClusterStats :: Options -> Bool -> Phase -> [Int] -> Bool -> IO ()
+printClusterStats opts machineread phase stats needhbal = do
   let values = prepareClusterValues machineread stats [needhbal]
-  printStats verbose machineread ClusterLvl phase values
+  printStats opts machineread ClusterLvl phase values
 
 -- | Check if any of cluster metrics is non-zero.
 clusterNeedsRebalance :: [Int] -> Bool
@@ -243,21 +251,24 @@ clusterNeedsRebalance stats = sum stats > 0
 instances residing on offline nodes.
 
 -}
-perGroupChecks :: Group.List -> GroupInfo -> GroupStats
-perGroupChecks gl (gidx, (nl, il)) =
+perGroupChecks :: Options -> Group.List -> GroupInfo -> GroupStats
+perGroupChecks opts gl (gidx, (nl, il)) =
   let grp = Container.find gidx gl
       offnl = filter Node.offline (Container.elems nl)
       n1violated = length . fst $ Cluster.computeBadItems nl il
+      gn1fail = length . filter (not . GlobalN1.canEvacuateNode (nl, il))
+                  $ IntMap.elems nl
       conflicttags = length $ filter (>0)
                      (map Node.conflictingPrimaries (Container.elems nl))
       offline_pri = sum . map length $ map Node.pList offnl
       offline_sec = length $ map Node.sList offnl
-      score = Cluster.compCV nl
+      score = Metrics.compCV nl
       groupstats = [ n1violated
                    , conflicttags
                    , offline_pri
                    , offline_sec
                    ]
+                   ++ [ gn1fail | optCapacity opts ]
   in ((grp, score), groupstats)
 
 -- | Use Hbal's iterateDepth to simulate group rebalance.
@@ -278,9 +289,9 @@ executeSimulation opts ini_tbl min_cv gidx nl il = do
 -- | Simulate group rebalance if group's score is not good
 maybeSimulateGroupRebalance :: Options -> GroupInfo -> IO GroupInfo
 maybeSimulateGroupRebalance opts (gidx, (nl, il)) = do
-  let ini_cv = Cluster.compCV nl
+  let ini_cv = Metrics.compCV nl
       ini_tbl = Cluster.Table nl il ini_cv []
-      min_cv = optMinScore opts
+      min_cv = optMinScore opts + Metrics.optimalCVScore nl
   if ini_cv < min_cv
     then return (gidx, (nl, il))
     else executeSimulation opts ini_tbl min_cv gidx nl il
@@ -310,11 +321,11 @@ main opts args = do
   (ClusterData gl fixed_nl ilf _ _) <- loadExternalData opts
   nlf <- setNodeStatus opts fixed_nl
 
-  let splitcluster = Cluster.splitCluster nlf ilf
+  let splitcluster = ClusterUtils.splitCluster nlf ilf
 
   when machineread $ printGroupsMappings gl
 
-  let groupsstats = map (perGroupChecks gl) splitcluster
+  let groupsstats = map (perGroupChecks opts gl) splitcluster
       clusterstats = map sum . transpose . map snd $ groupsstats
       needrebalance = clusterNeedsRebalance clusterstats
 
@@ -325,9 +336,9 @@ main opts args = do
                         then "Cluster needs rebalancing."
                         else "No need to rebalance cluster, no problems found."
 
-  mapM_ (printGroupStats verbose machineread Initial) groupsstats
+  mapM_ (printGroupStats opts machineread Initial) groupsstats
 
-  printClusterStats verbose machineread Initial clusterstats needrebalance
+  printClusterStats opts machineread Initial clusterstats needrebalance
 
   let exitOK = nosimulation || not needrebalance
       simulate = not nosimulation && needrebalance
@@ -335,13 +346,13 @@ main opts args = do
   rebalancedcluster <- maybeSimulateRebalance simulate opts splitcluster
 
   when (simulate || machineread) $ do
-    let newgroupstats = map (perGroupChecks gl) rebalancedcluster
+    let newgroupstats = map (perGroupChecks opts gl) rebalancedcluster
         newclusterstats = map sum . transpose . map snd $ newgroupstats
         newneedrebalance = clusterNeedsRebalance clusterstats
 
-    mapM_ (printGroupStats verbose machineread Rebalanced) newgroupstats
+    mapM_ (printGroupStats opts machineread Rebalanced) newgroupstats
 
-    printClusterStats verbose machineread Rebalanced newclusterstats
+    printClusterStats opts machineread Rebalanced newclusterstats
                            newneedrebalance
 
   printFinalHTC machineread
index 05e0d7b..0c49faa 100644 (file)
@@ -46,6 +46,8 @@ import Text.Printf (printf)
 
 import qualified Ganeti.HTools.Container as Container
 import qualified Ganeti.HTools.Cluster as Cluster
+import qualified Ganeti.HTools.Cluster.Utils as ClusterUtils
+import qualified Ganeti.HTools.Cluster.Metrics as Metrics
 import qualified Ganeti.HTools.Node as Node
 import qualified Ganeti.HTools.Group as Group
 import qualified Ganeti.HTools.Instance as Instance
@@ -101,7 +103,7 @@ calcGroupInfo g nl il =
       bn_size                    = length bad_nodes
       bi_size                    = length bad_instances
       n1h                        = bn_size == 0
-      score                      = Cluster.compCV nl
+      score                      = Metrics.compCV nl
   in GroupInfo (Group.name g) nl_size il_size bn_size bi_size n1h score
 
 -- | Helper to format one group row result.
@@ -121,7 +123,7 @@ showGroupInfo :: Int -> Group.List -> Node.List -> Instance.List -> IO ()
 showGroupInfo verbose gl nl il = do
   let cgrs   = map (\(gdx, (gnl, gil)) ->
                  calcGroupInfo (Container.find gdx gl) gnl gil) $
-                 Cluster.splitCluster nl il
+                 ClusterUtils.splitCluster nl il
       cn1h   = all giN1Status cgrs
       grs    = map groupRowFormatHelper cgrs
       header = ["Group", "Nodes", "Instances", "Bad_Nodes", "Bad_Instances",
@@ -192,5 +194,5 @@ main opts args = do
 
   maybePrintNodes shownodes "Cluster" (Cluster.printNodes nlf)
 
-  printf "Cluster coefficients:\n%s" (Cluster.printStats "  " nlf)::IO ()
-  printf "Cluster score: %.8f\n" (Cluster.compCV nlf)
+  printf "Cluster coefficients:\n%s" (Metrics.printStats "  " nlf)::IO ()
+  printf "Cluster score: %.8f\n" (Metrics.compCV nlf)
index 057f005..1fb6a55 100644 (file)
@@ -50,6 +50,7 @@ import Text.Printf (printf)
 import Ganeti.BasicTypes
 import qualified Ganeti.HTools.Container as Container
 import qualified Ganeti.HTools.Cluster as Cluster
+import qualified Ganeti.HTools.Cluster.Metrics as Metrics
 import qualified Ganeti.HTools.Node as Node
 import qualified Ganeti.HTools.Instance as Instance
 import qualified Ganeti.HTools.Backend.Rapi as Rapi
@@ -82,7 +83,7 @@ printCluster :: Node.List -> Instance.List
              -> String
 printCluster nl il =
   let (bad_nodes, bad_instances) = Cluster.computeBadItems nl il
-      ccv = Cluster.compCV nl
+      ccv = Metrics.compCV nl
       nodes = Container.elems nl
       insts = Container.elems il
       t_ram = sum . map Node.tMem $ nodes
index 9db1441..b9899be 100644 (file)
@@ -52,6 +52,7 @@ import Text.Printf (printf, hPrintf)
 import qualified Ganeti.HTools.AlgorithmParams as Alg
 import qualified Ganeti.HTools.Container as Container
 import qualified Ganeti.HTools.Cluster as Cluster
+import qualified Ganeti.HTools.Cluster.Metrics as Metrics
 import qualified Ganeti.HTools.Group as Group
 import qualified Ganeti.HTools.Node as Node
 import qualified Ganeti.HTools.Instance as Instance
@@ -379,8 +380,8 @@ printTiered False spec_map ini_nl fin_nl sreason = do
 -- | Displays the initial/final cluster scores.
 printClusterScores :: Node.List -> Node.List -> IO ()
 printClusterScores ini_nl fin_nl = do
-  printf "  - initial cluster score: %.8f\n" $ Cluster.compCV ini_nl::IO ()
-  printf "  -   final cluster score: %.8f\n" $ Cluster.compCV fin_nl
+  printf "  - initial cluster score: %.8f\n" $ Metrics.compCV ini_nl::IO ()
+  printf "  -   final cluster score: %.8f\n" $ Metrics.compCV fin_nl
 
 -- | Displays the cluster efficiency.
 printClusterEff :: Cluster.CStats -> Bool -> IO ()
@@ -493,7 +494,7 @@ main opts args = do
 
   when (verbose > 2) $
          hPrintf stderr "Initial coefficients: overall %.8f\n%s"
-                 (Cluster.compCV nl) (Cluster.printStats "  " nl)
+                 (Metrics.compCV nl) (Metrics.printStats "  " nl)
 
   printCluster machine_r (Cluster.totalResources nl) (length all_nodes)
     (Node.haveExclStorage nl)
index db6c473..0a29b77 100644 (file)
@@ -53,6 +53,7 @@ import qualified Ganeti.HTools.AlgorithmParams as Alg
 import Ganeti.HTools.CLI
 import qualified Ganeti.HTools.Container as Container
 import qualified Ganeti.HTools.Cluster as Cluster
+import qualified Ganeti.HTools.Cluster.Metrics as Metrics
 import Ganeti.HTools.ExtLoader
 import qualified Ganeti.HTools.Instance as Instance
 import Ganeti.HTools.Loader
@@ -131,7 +132,7 @@ allNodesCapacityFor inst (nl, _) =
 balance :: (Node.List, Instance.List) 
            -> ((Node.List, Instance.List), [MoveJob])
 balance (nl, il) =
-  let ini_cv = Cluster.compCV nl
+  let ini_cv = Metrics.compCV nl
       ini_tbl = Cluster.Table nl il ini_cv []
       balanceStep = Cluster.tryBalance
                       (Alg.defaultOptions { Alg.algMinGain = 0.0
index c1847d2..66c3fd1 100644 (file)
@@ -372,7 +372,7 @@ cancelRejectedJobs qstate cfg filters = do
   forM_ jobsToCancel $ \(job, fr) -> do
     let jid = qjId job
     logDebug $ "Cancelling job " ++ show (fromJobId jid)
-               ++ " because it was REJECTed by filter rule " ++ frUuid fr
+               ++ " because it was REJECTed by filter rule " ++ uuidOf fr
     -- First dequeue, then cancel.
     dequeueResult <- dequeueJob qstate jid
     case dequeueResult of
index 8c98083..34e55bb 100644 (file)
@@ -42,6 +42,7 @@ module Ganeti.JQScheduler.Filtering
   , matches
   ) where
 
+import qualified Data.ByteString as BS
 import Data.List
 import Data.Maybe
 import qualified Data.Map as Map
@@ -167,7 +168,7 @@ applyingFilter filters job =
 
 
 -- | SlotMap for filter rule rate limiting, having `FilterRule` UUIDs as keys.
-type RateLimitSlotMap = SlotMap String
+type RateLimitSlotMap = SlotMap BS.ByteString
 -- We would prefer FilterRule here but that has no Ord instance (yet).
 
 
@@ -179,7 +180,9 @@ data FilterChainState = FilterChainState
 
 -- | Update a `FilterChainState` if the given `CountMap` fits into its
 -- filtering SlotsMap.
-tryFitSlots :: FilterChainState -> CountMap String -> Maybe FilterChainState
+tryFitSlots :: FilterChainState
+            -> CountMap BS.ByteString
+            -> Maybe FilterChainState
 tryFitSlots st@FilterChainState{ rateLimitSlotMap = slotMap } countMap =
   if slotMap `hasSlotsFor` countMap
     then Just st{ rateLimitSlotMap = slotMap `occupySlots` countMap }
index 18fddb4..e1c91b3 100644 (file)
@@ -79,6 +79,7 @@ module Ganeti.JSON
   , nestedAccessByKeyDotted
   , branchOnField
   , addField
+  , maybeParseMap
   )
   where
 
@@ -537,3 +538,7 @@ branchOnField k _ _ _ = J.Error $ "Need an object to branch on key " ++ k
 addField :: (String, J.JSValue) -> J.JSValue -> J.JSValue
 addField (n,v) (J.JSObject obj) = J.JSObject $ JT.set_field obj n v
 addField _ jsval = jsval
+
+-- | Maybe obtain a map from a JSON object.
+maybeParseMap :: J.JSON a => J.JSValue -> Maybe (Map.Map String a)
+maybeParseMap = liftM fromContainer . readContainer <=< asJSObject
index 25310bc..c31305c 100644 (file)
@@ -1,7 +1,6 @@
 {-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeFamilies,
-             GeneralizedNewtypeDeriving,
-             StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances,
-             CPP #-}
+             MultiParamTypeClasses, GeneralizedNewtypeDeriving,
+             StandaloneDeriving, UndecidableInstances, CPP #-}
 
 {-| A pure implementation of MonadLog using MonadWriter
 
index bb793cf..ebd27b2 100644 (file)
@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+
 {-
 
 Copyright (C) 2014 Google Inc.
@@ -30,6 +32,9 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 module Ganeti.Metad.Config where
 
 import Control.Arrow (second)
+import Control.Monad ((>=>), mzero)
+import Control.Monad.Trans
+import Control.Monad.Trans.Maybe
 import qualified Data.List as List (isPrefixOf)
 import qualified Data.Map as Map
 import Text.JSON
@@ -96,48 +101,57 @@ getOsParamsWithVisibility json =
      Ok $ makeInstanceParams publicOsParams privateOsParams secretOsParams
 
 -- | Finds the IP address of the instance communication NIC in the
--- instance's NICs.
-getInstanceCommunicationIp :: JSObject JSValue -> Result String
-getInstanceCommunicationIp jsonObj =
-  getNics >>= getInstanceCommunicationNic >>= getIp
+-- instance's NICs. If the corresponding NIC isn't found, 'Nothing' is returned.
+getInstanceCommunicationIp :: JSObject JSValue -> Result (Maybe String)
+getInstanceCommunicationIp =
+    runMaybeT . (getNics >=> getInstanceCommunicationNic >=> getIp)
   where
+    getIp :: JSObject JSValue -> MaybeT Result String
     getIp nic =
       case lookup "ip" (fromJSObject nic) of
-        Nothing -> Error "Could not find instance communication IP"
-        Just (JSString ip) -> Ok (JSON.fromJSString ip)
-        _ -> Error "Instance communication IP is not a string"
+        Nothing -> failErrorT "Could not find instance communication IP"
+        Just (JSString ip) -> return (JSON.fromJSString ip)
+        _ -> failErrorT "Instance communication IP is not a string"
 
-    getInstanceCommunicationNic [] =
-      Error "Could not find instance communication NIC"
-    getInstanceCommunicationNic (JSObject nic:nics) =
+    getInstanceCommunicationNic :: [JSValue] -> MaybeT Result (JSObject JSValue)
+    getInstanceCommunicationNic [] = mzero -- no communication NIC found
+    getInstanceCommunicationNic (JSObject nic : nics) =
       case lookup "name" (fromJSObject nic) of
         Just (JSString name)
           | Constants.instanceCommunicationNicPrefix
             `List.isPrefixOf` JSON.fromJSString name ->
-            Ok nic
+            return nic
         _ -> getInstanceCommunicationNic nics
-    getInstanceCommunicationNic _ =
-      Error "Found wrong data in instance NICs"
+    getInstanceCommunicationNic (n : _) =
+      failErrorT $ "Found wrong data in instance NICs: " ++ show n
 
-    getNics =
+    getNics :: JSObject JSValue -> MaybeT Result [JSValue]
+    getNics jsonObj =
       case lookup "nics" (fromJSObject jsonObj) of
-        Nothing -> Error "Could not find OS parameters key 'nics'"
-        Just (JSArray nics) -> Ok nics
-        _ -> Error "Instance nics is not an array"
+        Nothing -> failErrorT "Could not find OS parameters key 'nics'"
+        Just (JSArray nics) -> return nics
+        _ -> failErrorT "Instance nics is not an array"
+
+    -- | A helper function for failing a 'Result' wrapped in a monad
+    -- transformer.
+    failErrorT :: (MonadTrans t) => String -> t Result a
+    failErrorT = lift . JSON.Error
 
 -- | Extracts the OS parameters from the instance's parameters and
 -- returns a data structure containing all the OS parameters and their
 -- visibility indexed by the instance's IP address which is used in
 -- the instance communication NIC.
-getInstanceParams :: JSValue -> Result (String, InstanceParams)
+getInstanceParams :: JSValue -> Result (String, Maybe InstanceParams)
 getInstanceParams json =
     case json of
       JSObject jsonObj -> do
         name <- case lookup "name" (fromJSObject jsonObj) of
-                  Nothing -> Error "Could not find instance name"
-                  Just (JSString x) -> Ok (JSON.fromJSString x)
-                  _ -> Error "Name is not a string"
-        ip <- getInstanceCommunicationIp jsonObj
-        Ok (name, Map.fromList [(ip, json)])
+                  Nothing -> failError "Could not find instance name"
+                  Just (JSString x) -> return (JSON.fromJSString x)
+                  _ -> failError "Name is not a string"
+        m'ip <- getInstanceCommunicationIp jsonObj
+        return (name, fmap (\ip -> Map.fromList [(ip, json)]) m'ip)
       _ ->
-        Error "Expecting a dictionary"
+        failError "Expecting a dictionary"
+  where
+    failError = JSON.Error
diff --git a/src/Ganeti/Metad/ConfigCore.hs b/src/Ganeti/Metad/ConfigCore.hs
new file mode 100644 (file)
index 0000000..7211c7e
--- /dev/null
@@ -0,0 +1,134 @@
+{-# LANGUAGE TupleSections, TemplateHaskell, CPP, UndecidableInstances,
+    MultiParamTypeClasses, TypeFamilies, GeneralizedNewtypeDeriving #-}
+{-| Functions of the metadata daemon exported for RPC
+
+-}
+
+{-
+
+Copyright (C) 2014 Google Inc.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+-}
+module Ganeti.Metad.ConfigCore where
+
+import Control.Applicative
+import Control.Concurrent.MVar.Lifted
+import Control.Monad.Base
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+import Language.Haskell.TH (Name)
+import qualified Text.JSON as J
+
+import Ganeti.BasicTypes
+import Ganeti.Errors
+import qualified Ganeti.JSON as J
+import Ganeti.Logging as L
+import Ganeti.Metad.Config as Config
+import Ganeti.Metad.Types (InstanceParams)
+
+-- * The monad in which all the Metad functions execute
+
+data MetadHandle = MetadHandle
+  { mhInstParams :: MVar InstanceParams
+  }
+
+-- | A type alias for easier referring to the actual content of the monad
+-- when implementing its instances.
+type MetadMonadIntType = ReaderT MetadHandle IO
+
+-- | The internal part of the monad without error handling.
+newtype MetadMonadInt a = MetadMonadInt
+  { getMetadMonadInt :: MetadMonadIntType a }
+  deriving ( Functor, Applicative, Monad, MonadIO, MonadBase IO
+           , L.MonadLog )
+
+instance MonadBaseControl IO MetadMonadInt where
+#if MIN_VERSION_monad_control(1,0,0)
+-- Needs Undecidable instances
+  type StM MetadMonadInt b = StM MetadMonadIntType b
+  liftBaseWith f = MetadMonadInt . liftBaseWith
+                   $ \r -> f (r . getMetadMonadInt)
+  restoreM = MetadMonadInt . restoreM
+#else
+  newtype StM MetadMonadInt b = StMMetadMonadInt
+    { runStMMetadMonadInt :: StM MetadMonadIntType b }
+  liftBaseWith f = MetadMonadInt . liftBaseWith
+                   $ \r -> f (liftM StMMetadMonadInt . r . getMetadMonadInt)
+  restoreM = MetadMonadInt . restoreM . runStMMetadMonadInt
+#endif
+
+-- | Runs the internal part of the MetadMonad monad on a given daemon
+-- handle.
+runMetadMonadInt :: MetadMonadInt a -> MetadHandle -> IO a
+runMetadMonadInt (MetadMonadInt k) = runReaderT k
+
+-- | The complete monad with error handling.
+type MetadMonad = ResultT GanetiException MetadMonadInt
+
+-- * Basic functions in the monad
+
+metadHandle :: MetadMonad MetadHandle
+metadHandle = lift . MetadMonadInt $ ask
+
+instParams :: MetadMonad InstanceParams
+instParams = readMVar . mhInstParams =<< metadHandle
+
+modifyInstParams :: (InstanceParams -> MetadMonad (InstanceParams, a))
+                 -> MetadMonad a
+modifyInstParams f = do
+  h <- metadHandle
+  modifyMVar (mhInstParams h) f
+
+-- * Functions available to the RPC module
+
+-- Just a debugging function
+echo :: String -> MetadMonad String
+echo = return
+
+-- | Update the configuration with the received instance parameters.
+updateConfig :: J.JSValue -> MetadMonad ()
+updateConfig input = do
+  (name, m'instanceParams) <- J.fromJResultE "Could not get instance parameters"
+                              $ Config.getInstanceParams input
+  case m'instanceParams of
+    Nothing -> L.logInfo $ "No communication NIC for instance " ++ name
+                           ++ ", skipping"
+    Just instanceParams -> do
+      cfg' <- modifyInstParams $ \cfg ->
+        let cfg' = mergeConfig cfg instanceParams
+         in return (cfg', cfg')
+      L.logInfo $
+        "Updated instance " ++ name ++ " configuration"
+      L.logDebug $ "Instance configuration: " ++ show cfg'
+
+-- * The list of all functions exported to RPC.
+
+exportedFunctions :: [Name]
+exportedFunctions = [ 'echo
+                    , 'updateConfig
+                    ]
index 62ea43c..ad32e65 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TupleSections, TemplateHaskell #-}
 {-| Configuration server for the metadata daemon.
 
 -}
@@ -34,71 +34,34 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 -}
 module Ganeti.Metad.ConfigServer where
 
-import Control.Concurrent
-import Control.Exception (try, finally)
-import Control.Monad (unless)
-import Text.JSON
-import System.IO.Error (isEOFError)
+import Control.Exception (finally)
+import Control.Monad.Reader
 
 import Ganeti.Path as Path
 import Ganeti.Daemon (DaemonOptions, cleanupSocket, describeError)
-import qualified Ganeti.Logging as Logging
 import Ganeti.Runtime (GanetiDaemon(..), GanetiGroup(..), MiscGroup(..))
-import Ganeti.UDSServer (Client, ConnectConfig(..), Server, ServerConfig(..))
+import Ganeti.THH.RPC
+import Ganeti.UDSServer (ConnectConfig(..), ServerConfig(..))
 import qualified Ganeti.UDSServer as UDSServer
 import Ganeti.Utils (FilePermissions(..))
 
-import Ganeti.Metad.Config as Config
-import Ganeti.Metad.Types (InstanceParams)
+import Ganeti.Metad.ConfigCore
 
--- | Update the configuration with the received instance parameters.
-updateConfig :: MVar InstanceParams -> String -> IO ()
-updateConfig config str =
-  case decode str of
-    Error err ->
-      Logging.logDebug $ show err
-    Ok x ->
-      case Config.getInstanceParams x of
-        Error err ->
-          Logging.logError $ "Could not get instance parameters: " ++ err
-        Ok (name, instanceParams) -> do
-          cfg <- takeMVar config
-          let cfg' = mergeConfig cfg instanceParams
-          putMVar config cfg'
-          Logging.logInfo $
-            "Updated instance " ++ show name ++ " configuration"
-          Logging.logDebug $ "Instance configuration: " ++ show cfg'
+-- * The handler that converts RPCs to calls to the above functions
 
--- | Reads messages from clients and update the configuration
--- according to these messages.
-acceptConfig :: MVar InstanceParams -> Client -> IO ()
-acceptConfig config client =
-  do res <- try $ UDSServer.recvMsg client
-     case res of
-       Left err -> do
-         unless (isEOFError err) .
-           Logging.logDebug $ show err
-         return ()
-       Right str -> do
-         Logging.logDebug $ "Received: " ++ str
-         updateConfig config str
+handler :: RpcServer MetadMonadInt
+handler = $( mkRpcM exportedFunctions )
 
--- | Loop that accepts clients and dispatches them to an isolated
--- thread that will handle the client's requests.
-acceptClients :: MVar InstanceParams -> Server -> IO ()
-acceptClients config server =
-  do client <- UDSServer.acceptClient server
-     _ <- forkIO $ acceptConfig config client
-     acceptClients config server
+-- * The main server code
 
-start :: DaemonOptions -> MVar InstanceParams -> IO ()
+start :: DaemonOptions -> MetadHandle -> IO ()
 start _ config = do
      socket_path <- Path.defaultMetadSocket
      cleanupSocket socket_path
      server <- describeError "binding to the socket" Nothing (Just socket_path)
                $ UDSServer.connectServer metadConfig True socket_path
      finally
-       (acceptClients config server)
+       (forever $ runMetadMonadInt (UDSServer.listener handler server) config)
        (UDSServer.closeServer server)
   where
     metadConfig =
index 16d0edc..a333bd8 100644 (file)
@@ -37,6 +37,7 @@ import Control.Concurrent
 import qualified Data.Map (empty)
 
 import Ganeti.Daemon (DaemonOptions)
+import Ganeti.Metad.ConfigCore (MetadHandle(..))
 import qualified Ganeti.Metad.ConfigServer as ConfigServer
 import qualified Ganeti.Metad.WebServer as WebServer
 
@@ -44,4 +45,4 @@ start :: DaemonOptions -> IO ()
 start opts =
   do config <- newMVar Data.Map.empty
      _ <- forkIO $ WebServer.start opts config
-     ConfigServer.start opts config
+     ConfigServer.start opts (MetadHandle config)
index 5fc4b33..338d3e4 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}
 {-| Web server for the metadata daemon.
 
 -}
@@ -40,6 +40,8 @@ import Control.Concurrent (MVar, readMVar)
 import Control.Monad.Error.Class (MonadError, catchError, throwError)
 import Control.Monad.IO.Class (liftIO)
 import qualified Control.Monad.CatchIO as CatchIO (catch)
+import qualified Data.CaseInsensitive as CI
+import Data.List (intercalate)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified Data.ByteString.Char8 as ByteString (pack, unpack)
@@ -73,10 +75,17 @@ lookupInstanceParams inst params =
     Nothing -> throwError $ "Could not get instance params for " ++ show inst
     Just x -> return x
 
+-- | The 404 "not found" error.
 error404 :: MetaM
 error404 = do
-  modifyResponse . setResponseStatus 404 $ ByteString.pack "Not found"
-  writeBS $ ByteString.pack "Resource not found"
+  modifyResponse $ setResponseStatus 404 "Not found"
+  writeBS "Resource not found"
+
+-- | The 405 "method not allowed error", including the list of allowed methods.
+error405 :: [Method] -> MetaM
+error405 ms = modifyResponse $
+  addHeader (CI.mk "Allow") (ByteString.pack . intercalate ", " $ map show ms)
+  . setResponseStatus 405 "Method not allowed"
 
 maybeResult :: MonadError String m => Result t -> (t -> m a) -> m a
 maybeResult (Error err) _ = throwError err
@@ -173,8 +182,12 @@ handleMetadata params GET  "ganeti" "latest" script | isScript script =
                   ])
 handleMetadata _ GET  "ganeti" "latest" "read" =
   liftIO $ Logging.logInfo "ganeti READ"
+handleMetadata _ _  "ganeti" "latest" "read" =
+  error405 [GET]
 handleMetadata _ POST "ganeti" "latest" "write" =
   liftIO $ Logging.logInfo "ganeti WRITE"
+handleMetadata _ _ "ganeti" "latest" "write" =
+  error405 [POST]
 handleMetadata _ _ _ _ _ =
   error404
 
index c3cf128..1cb6aa1 100644 (file)
@@ -40,6 +40,7 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 module Ganeti.Network
   ( PoolPart(..)
   , netIpv4NumHosts
+  , ip4BaseAddr
   , getReservedCount
   , getFreeCount
   , isFull
@@ -56,6