[PATCH pve-cluster 08/10] cfs: add hook registry for change notification consumers

[Hannes Laimer <h.laimer@proxmox.com>]

Reacting to a cluster config change should look like handling an API
request, a path template with placeholders that turn into parameters
and a code reference that receives them.

The templates go to pmxcfs as they are, which matches them and
delivers the captured values, so the registry only turns those into
runs after checking the event type. It refuses at registration what
the daemon would refuse at subscribe time, so a bad template fails
where the hook is written rather than in the listener. Each run
carries a key made of the hook name and its parameters, so an executor
can keep one run per key in flight and collapse the burst that
repeated saves of the same file produce, a config update through the
API being several of them. A resync becomes a parameterless run of
every hook.

Signed-off-by: Hannes Laimer <h.laimer@proxmox.com>
---
 debian/pve-cluster.install |   1 +
 src/PVE/Cluster/Hooks.pm   | 134 +++++++++++++++++++++++
 src/PVE/Cluster/Makefile   |   2 +-
 src/test/Makefile          |   6 +-
 src/test/hooks_test.pl     | 219 +++++++++++++++++++++++++++++++++++++
 5 files changed, 360 insertions(+), 2 deletions(-)
 create mode 100644 src/PVE/Cluster/Hooks.pm
 create mode 100644 src/test/hooks_test.pl

diff --git a/debian/pve-cluster.install b/debian/pve-cluster.install
index 77e3244..b8ebff7 100644
--- a/debian/pve-cluster.install
+++ b/debian/pve-cluster.install
@@ -4,6 +4,7 @@ usr/bin/pmxcfs
 usr/lib/
 usr/share/man/man8/pmxcfs.8
 usr/share/perl5/PVE/Cluster.pm
+usr/share/perl5/PVE/Cluster/Hooks.pm
 usr/share/perl5/PVE/Cluster/IPCConst.pm
 usr/share/perl5/PVE/Cluster/Watch.pm
 usr/share/perl5/PVE/IPCC.pm
diff --git a/src/PVE/Cluster/Hooks.pm b/src/PVE/Cluster/Hooks.pm
new file mode 100644
index 0000000..e6c6001
--- /dev/null
+++ b/src/PVE/Cluster/Hooks.pm
@@ -0,0 +1,134 @@
+package PVE::Cluster::Hooks;
+
+use strict;
+use warnings;
+
+use JSON;
+
+# A hook subscribes to a memdb path template and runs its code with the
+# placeholder values captured from a matching change. Runs are keyed by hook
+# and parameters, so a burst collapses into one rerun. An event only says the
+# state changed, so a run reads it as it is then, which is what keeps
+# collapsing safe. Runs are not serialized, so a hook writing shared
+# state takes the same locks an API handler would.
+
+my $hooks = {};
+my $order = [];
+
+my $default_types = [qw(create write rename delete mkdir)];
+my $known_types = { map { $_ => 1 } qw(create write mtime rename delete mkdir) };
+
+# what pmxcfs accepts in one subscription
+my $max_hooks = 256;
+
+sub register_hook {
+    my ($class, $info) = @_;
+
+    my $name = $info->{name} // die "hook registration without a name\n";
+    die "hook '$name': invalid name\n" if $name !~ m/^[a-zA-Z][\w-]*$/;
+    die "hook '$name': already registered\n" if $hooks->{$name};
+    die "hook '$name': no path\n" if !defined($info->{path});
+    die "hook '$name': no code\n" if ref($info->{code}) ne 'CODE';
+    die "hook '$name': at most $max_hooks hooks can be registered\n"
+        if scalar($order->@*) >= $max_hooks;
+
+    my $template = compile_template($name, $info->{path});
+
+    my $types = $info->{types} // $default_types;
+    for my $type ($types->@*) {
+        die "hook '$name': unknown event type '$type'\n" if !$known_types->{$type};
+    }
+
+    $hooks->{$name} = {
+        name => $name,
+        code => $info->{code},
+        types => { map { $_ => 1 } $types->@* },
+        template => $template,
+    };
+    push $order->@*, $name;
+
+    return;
+}
+
+# Fails a bad path at registration instead of leaving it for the daemon.
+sub compile_template {
+    my ($name, $path) = @_;
+
+    $path =~ s!^/+!!;
+    die "hook '$name': empty path\n" if $path eq '';
+
+    my @comps = split(m!/!, $path, -1);
+    my $seen = {};
+
+    for my $i (0 .. $#comps) {
+        my $comp = $comps[$i];
+        die "hook '$name': path component has zero length\n" if $comp eq '';
+        next if $comp !~ m/[{}]/;
+
+        my ($prefix, $body, $suffix) = $comp =~ m/^([^{}]*)\{([^{}]*)\}([^{}]*)$/
+            or die "hook '$name': malformed path component '$comp'\n";
+
+        if ($body =~ m/^([A-Za-z_][A-Za-z0-9_]*)\.\.\.$/) {
+            die "hook '$name': '{$1...}' must be the last component\n"
+                if $i != $#comps || $prefix ne '' || $suffix ne '';
+            die "hook '$name': placeholder '$1' used twice\n" if $seen->{$1}++;
+            next;
+        }
+
+        my ($pname) = $body =~ m/^([A-Za-z_][A-Za-z0-9_]*)$/
+            or die "hook '$name': malformed path component '$comp'\n";
+        die "hook '$name': placeholder '$pname' used twice\n" if $seen->{$pname}++;
+    }
+
+    return $path;
+}
+
+sub run_key {
+    my ($name, $param) = @_;
+
+    return $name if !scalar(keys $param->%*);
+
+    return "$name:" . JSON->new->canonical->encode($param);
+}
+
+# pmxcfs already matched the templates and delivers the parameter sets per
+# hook name, so only the event type is filtered here.
+sub dispatch {
+    my ($class, $event) = @_;
+
+    my @runs;
+
+    if ($event->{type} eq 'resync') {
+        for my $name ($order->@*) {
+            push @runs, { hook => $hooks->{$name}, param => {}, key => $name, event => $event };
+        }
+        return \@runs;
+    }
+
+    my $params = $event->{params} // {};
+    for my $name ($order->@*) {
+        my $hook = $hooks->{$name};
+        next if !$hook->{types}->{ $event->{type} };
+
+        for my $param (($params->{$name} // [])->@*) {
+            my $key = run_key($name, $param);
+            push @runs, { hook => $hook, param => $param, key => $key, event => $event };
+        }
+    }
+
+    return \@runs;
+}
+
+sub subscription {
+    my ($class) = @_;
+
+    return { patterns => { map { $_ => $hooks->{$_}->{template} } $order->@* } };
+}
+
+sub hooks {
+    my ($class) = @_;
+
+    return [map { $hooks->{$_} } $order->@*];
+}
+
+1;
diff --git a/src/PVE/Cluster/Makefile b/src/PVE/Cluster/Makefile
index 7beb976..0da7838 100644
--- a/src/PVE/Cluster/Makefile
+++ b/src/PVE/Cluster/Makefile
@@ -1,6 +1,6 @@
 PVEDIR=$(DESTDIR)/usr/share/perl5/PVE
 
-SOURCES=IPCConst.pm Setup.pm Watch.pm
+SOURCES=Hooks.pm IPCConst.pm Setup.pm Watch.pm
 
 .PHONY: install
 install: $(SOURCES)
diff --git a/src/test/Makefile b/src/test/Makefile
index 7b36fca..de07608 100644
--- a/src/test/Makefile
+++ b/src/test/Makefile
@@ -4,7 +4,7 @@ cpgtest: cpgtest.c
 	gcc -Wall cpgtest.c $(shell pkg-config --cflags --libs libcpg libqb) -o cpgtest
 
 .PHONY: check install clean distclean
-check: corosync-parser-test test-mac-prefix watch-client-test
+check: corosync-parser-test test-mac-prefix watch-client-test hooks-test
 
 .PHONY: corosync-parser-test
 corosync-parser-test:
@@ -18,5 +18,9 @@ test-mac-prefix:
 watch-client-test:
 	perl watch_client_test.pl
 
+.PHONY: hooks-test
+hooks-test:
+	perl hooks_test.pl
+
 distclean: clean
 clean:
diff --git a/src/test/hooks_test.pl b/src/test/hooks_test.pl
new file mode 100644
index 0000000..8adceda
--- /dev/null
+++ b/src/test/hooks_test.pl
@@ -0,0 +1,219 @@
+#!/usr/bin/perl
+
+use lib '..';
+
+use strict;
+use warnings;
+
+use Test::More;
+
+use PVE::Cluster::Hooks;
+
+my $noop = sub { };
+
+PVE::Cluster::Hooks->register_hook({
+    name => 'guest',
+    path => 'nodes/{node}/qemu-server/{vmid}.conf',
+    code => $noop,
+});
+
+PVE::Cluster::Hooks->register_hook({
+    name => 'dc',
+    path => '/datacenter.cfg',
+    types => ['write', 'rename'],
+    code => $noop,
+});
+
+PVE::Cluster::Hooks->register_hook({
+    name => 'sdn',
+    path => 'sdn/{file...}',
+    code => $noop,
+});
+
+PVE::Cluster::Hooks->register_hook({
+    name => 'locks',
+    path => 'priv/lock/{path...}',
+    types => ['mtime', 'create', 'delete'],
+    code => $noop,
+});
+
+is_deeply(
+    [map { $_->{name} } PVE::Cluster::Hooks->hooks()->@*],
+    ['guest', 'dc', 'sdn', 'locks'],
+    'hooks are kept in registration order',
+);
+
+is_deeply(
+    PVE::Cluster::Hooks->subscription(),
+    {
+        patterns => {
+            guest => 'nodes/{node}/qemu-server/{vmid}.conf',
+            dc => 'datacenter.cfg',
+            sdn => 'sdn/{file...}',
+            locks => 'priv/lock/{path...}',
+        },
+    },
+    'subscription sends every template',
+);
+
+my $runs = sub {
+    my ($event) = @_;
+    return [map { { name => $_->{hook}->{name}, param => $_->{param}, key => $_->{key} } }
+        PVE::Cluster::Hooks->dispatch($event)->@*];
+};
+
+my $guest = { node => 'n1', vmid => '100' };
+
+is_deeply(
+    $runs->({
+        type => 'write',
+        path => 'nodes/n1/qemu-server/100.conf',
+        params => { guest => [$guest] },
+    }),
+    [{ name => 'guest', param => $guest, key => 'guest:{"node":"n1","vmid":"100"}' }],
+    'delivered parameters become the run and its key',
+);
+
+is_deeply(
+    $runs->({
+        type => 'rename',
+        path => 'nodes/n1/qemu-server/100.conf',
+        to => 'nodes/n2/qemu-server/100.conf',
+        params => { guest => [$guest, { node => 'n2', vmid => '100' }] },
+    }),
+    [
+        { name => 'guest', param => $guest, key => 'guest:{"node":"n1","vmid":"100"}' },
+        {
+            name => 'guest',
+            param => { node => 'n2', vmid => '100' },
+            key => 'guest:{"node":"n2","vmid":"100"}',
+        },
+    ],
+    'every delivered parameter set is a run of its own',
+);
+
+is_deeply(
+    $runs->({ type => 'write', path => 'datacenter.cfg', params => { dc => [{}] } }),
+    [{ name => 'dc', param => {}, key => 'dc' }],
+    'a parameterless hook is keyed by its name',
+);
+
+is_deeply(
+    $runs->({ type => 'create', path => 'datacenter.cfg', params => { dc => [{}] } }),
+    [],
+    'event types outside the list are ignored',
+);
+
+is_deeply(
+    $runs->({
+        type => 'mtime',
+        path => 'nodes/n1/qemu-server/100.conf',
+        params => { guest => [$guest] },
+    }),
+    [],
+    'mtime is not delivered by default',
+);
+
+is_deeply(
+    $runs->({
+        type => 'mtime',
+        path => 'priv/lock/file-storage_cfg/a',
+        params => { locks => [{ path => 'file-storage_cfg/a' }] },
+    }),
+    [{
+        name => 'locks',
+        param => { path => 'file-storage_cfg/a' },
+        key => 'locks:{"path":"file-storage_cfg/a"}',
+    }],
+    'a spanning placeholder carries the rest of the path',
+);
+
+is_deeply(
+    $runs->({
+        type => 'write',
+        path => 'sdn/zones.cfg',
+        params => { sdn => [{ file => 'zones.cfg' }], other => [{}] },
+    }),
+    [{ name => 'sdn', param => { file => 'zones.cfg' }, key => 'sdn:{"file":"zones.cfg"}' }],
+    'parameters for unknown hooks are ignored',
+);
+
+is_deeply(
+    $runs->({ type => 'write', path => 'datacenter.cfg' }),
+    [],
+    'an event without parameters runs nothing',
+);
+
+my $untouched = { type => 'delete', path => 'datacenter.cfg', params => { dc => [{}] } };
+PVE::Cluster::Hooks->dispatch($untouched);
+is_deeply(
+    $untouched,
+    { type => 'delete', path => 'datacenter.cfg', params => { dc => [{}] } },
+    'dispatch leaves the event alone',
+);
+
+is_deeply(
+    [sort map { $_->{key} } $runs->({ type => 'resync' })->@*],
+    ['dc', 'guest', 'locks', 'sdn'],
+    'a resync runs every hook without parameters',
+);
+
+my $fails = sub {
+    my ($info, $like, $desc) = @_;
+    eval { PVE::Cluster::Hooks->register_hook($info) };
+    like($@, $like, $desc);
+};
+
+$fails->(
+    { name => 'guest', path => 'x', code => $noop },
+    qr/already registered/,
+    'duplicate names are rejected',
+);
+$fails->(
+    { name => '1bad', path => 'x', code => $noop },
+    qr/invalid name/,
+    'names must start with a letter',
+);
+$fails->({ name => 'nocode', path => 'x' }, qr/no code/, 'a hook needs code');
+$fails->(
+    { name => 'badtype', path => 'x', types => ['chmod'], code => $noop },
+    qr/unknown event type/,
+    'event types are validated',
+);
+$fails->(
+    { name => 'twice', path => 'a/{x}/{x}', code => $noop },
+    qr/used twice/,
+    'placeholder names must be unique',
+);
+$fails->(
+    { name => 'broken', path => 'a/{x', code => $noop },
+    qr/malformed path component/,
+    'unterminated placeholders are rejected',
+);
+$fails->(
+    { name => 'double', path => 'a/{x}{y}', code => $noop },
+    qr/malformed path component/,
+    'a component holds one placeholder at most',
+);
+$fails->(
+    { name => 'typed', path => 'sdn/{file:x}', code => $noop },
+    qr/malformed path component/,
+    'a placeholder holds a name and nothing else',
+);
+$fails->(
+    { name => 'middle', path => '{x...}/b', code => $noop },
+    qr/must be the last component/,
+    'the spanning placeholder comes last',
+);
+$fails->(
+    { name => 'slashes', path => 'a//b', code => $noop },
+    qr/zero length/,
+    'empty components are rejected',
+);
+$fails->(
+    { name => 'empty', path => '/', code => $noop },
+    qr/empty path/,
+    'an empty template is rejected',
+);
+
+done_testing();
-- 
2.47.3