Mark the guest we are running in, and refuse to power it off

One of the guests in the list is the machine tCMS is running on -- it is
acting as dom0, and it is the thing serving the page the buttons are drawn
on.  Powering it off or destroying it takes the site down along with
whatever asked for that, and nothing said so.

A guest whose name matches this host's now carries a "this server" badge
and is offered neither Power Off nor Destroy.  Snapshot stays: it is not
destructive, and a guest that cannot be snapshotted is less useful than
one that can.

Hiding the buttons is not the guard, so act() refuses those two actions
for it as well -- /guest/act is a POST anybody holding the admin acl can
craft by hand, and if it went through there would be nothing left running
to report the mistake.

The name is compared short as well as long, since a libvirt domain is
usually called 'dux' where the host calls itself 'dux.troglodyne.net', but
never short against short, which would make every 'dux' anywhere this
server.  Matching is on the guest name alone with no reference to which
hypervisor it is on, so a namesake elsewhere is treated as this server
too -- erring towards refusing a shutdown is the safe direction.

Co-Authored-By: Claude Opus 5 (1M context) <noreply@anthropic.com>
Claude-Session: https://claude.ai/code/session_01XKP7GQfo5E129BxZZHbB1M

lib/Trog/DataSource/Virt.pm

@@ -7,8 +7,11 @@ no warnings 'experimental';
 use feature qw{signatures state};
 
 use File::Path();
+use Sys::Hostname::FQDN();
 use Sys::Virt();
 
+use Trog::Config();
+
 use Trog::Log qw{WARN INFO};
 
 =head1 Trog::DataSource::Virt
@@ -91,6 +94,46 @@ sub _state_name ($state) {
     return $states[$state] // 'unknown';
 }
 
+# What this machine calls itself.  Not a state var so that a test can pretend
+# to be a different host without having to lie to Sys::Hostname.
+our $hostname;
+
+sub _hostname {
+    return $hostname if defined $hostname;
+
+    local $@;
+
+    # Sys::Hostname croaks rather than returning undef when it cannot tell, and
+    # the configured hostname is the next best thing we know about ourselves.
+    $hostname = eval { Sys::Hostname::FQDN::fqdn() }
+      || eval { Trog::Config->get()->param('general.hostname') }
+      || '';
+
+    return $hostname;
+}
+
+=head2 _is_self($name)
+
+Whether a guest by this name is the machine we are running on.
+
+Such a guest is acting as dom0: it is serving the page the guest list appears
+on, so powering it off or destroying it takes the site down along with whatever
+asked for that.
+
+Returns true if the guest name is the same as the fqdn of this machine.
+Returns false otherwise.
+
+=cut
+
+sub _is_self ($name) {
+    my $me = lc( _hostname() );
+    $name = lc( $name // '' );
+    print("Name comp: $me $name\n");
+
+    return 1 if $name eq $me;
+    return 0;
+}
+
 =head2 posts($series, $query) = @posts
 
 One post per guest, across every hypervisor the series' relations pulled in.
@@ -149,6 +192,7 @@ sub _post_for ( $domain, $hypervisor, $series, $form ) {
         domain           => $name,
         state            => _state_name( $info->{state} ),
         is_active        => $domain->is_active() ? 1 : 0,
+        is_self          => _is_self($name),
         memory           => $info->{memory},
         vcpus            => $info->{nrVirtCpu},
         hypervisor       => $hypervisor->{id},
@@ -266,6 +310,15 @@ sub act ( $action, $conn_uri, $domain_name, $user ) {
     my ($safe) = $domain_name =~ m/^([A-Za-z0-9._-]+)$/;
     return ( 0, 'bad guest name' ) unless $safe;
 
+    # The template draws neither of these buttons for this guest; this is what
+    # actually stops it happening.  /guest/act is a POST anybody holding the
+    # admin acl can craft by hand, and if it went through there would be
+    # nothing left running to report the mistake.
+    if ( _is_self($safe) && ( $action // '' ) =~ m/^(?:poweroff|destroy)$/ ) {
+        WARN("Refused guest action '$action' on '$safe': that is this server");
+        return ( 0, "'$safe' is this server -- refusing to $action it" );
+    }
+
     my ( $conn, $why ) = _connect($conn_uri);
     return ( 0, "could not reach the hypervisor: $why" ) unless $conn;
 

t/Trog-DataSource-Virt.t

@@ -68,6 +68,11 @@ $virtmock->redefine(
     }
 );
 
+# Every subtest below that does not say otherwise runs as a machine which is
+# not one of the fake guests -- otherwise the suite's answers would depend on
+# what the box running it happens to be called.
+$Trog::DataSource::Virt::hostname = 'spec-host-that-is-no-guest';
+
 my $series = {
     child_form  => 'guests.tx',
     tags        => ['guests'],
@@ -98,6 +103,40 @@ subtest 'guests become posts' => sub {
     is( $posts[0]{visibility}, 'private', 'and its visibility' );
 };
 
+subtest 'the guest this server runs on is marked as such' => sub {
+    local $Trog::DataSource::Virt::hostname = 'alpha';
+
+    my @posts = Trog::DataSource::Virt::posts( $series, { user_acls => ['admin'] } );
+    is( $posts[0]{is_self}, 1, 'the guest named after this machine is flagged' );
+    is( $posts[1]{is_self}, 0, 'and the one that merely lives beside it is not' );
+};
+
+subtest 'a guest is this server when it is named like it' => sub {
+    my @same = (
+        [ 'foo',                'foo'                => 'the same name' ],
+        [ 'foo',                'FOO'                => 'the same name in another case' ],
+        [ 'foo.troglodyne.net', 'foo.troglodyne.net' => 'both fully qualified' ],
+    );
+    foreach my $case (@same) {
+        my ( $guest, $host, $why ) = @$case;
+        local $Trog::DataSource::Virt::hostname = $host;
+        ok( Trog::DataSource::Virt::_is_self($guest), "$why is this server" );
+    }
+
+    my @different = (
+        [ 'beta',               'foo'                => 'a different name' ],
+        [ 'fooling',            'foo'                => 'a name this one is only a prefix of' ],
+        [ 'foo.test.test',      'foo.troglodyne.net' => 'the same label in someone else\'s domain' ],
+        [ '',                   'foo'                => 'a guest with no name at all' ],
+        [ 'foo',                ''                   => 'any guest, when we cannot tell what we are called' ],
+    );
+    foreach my $case (@different) {
+        my ( $guest, $host, $why ) = @$case;
+        local $Trog::DataSource::Virt::hostname = $host;
+        ok( !Trog::DataSource::Virt::_is_self($guest), "$why is not" );
+    }
+};
+
 subtest 'an unreachable hypervisor says so rather than vanishing' => sub {
     $connect_fails = 1;
     my @posts = Trog::DataSource::Virt::posts( $series, { user_acls => ['admin'] } );
@@ -150,6 +189,37 @@ subtest 'act() refuses what it should' => sub {
     is_deeply( \@CALLS, [], 'having done nothing' );
 };
 
+subtest 'act() will not take the server down with it' => sub {
+
+    # Hiding the buttons is not the guard: /guest/act is a POST anybody with
+    # the admin acl can craft, and if this went through there would be nothing
+    # left running to say what happened.
+    local $Trog::DataSource::Virt::hostname = 'alpha';
+
+    foreach my $action (qw{poweroff destroy}) {
+        @CALLS = ();
+        my ( $ok, $message ) = Trog::DataSource::Virt::act( $action, 'test:///default', 'alpha', 'specadmin' );
+        ok( !$ok, "$action on the guest we are running in is refused" );
+        like( $message, qr/is this server/, 'saying why' );
+        is_deeply( \@CALLS, [], "and the $action never reached libvirt" );
+    }
+
+    # The rest are not destructive, and a guest that cannot be snapshotted is
+    # less useful than one that can.
+    foreach my $action (qw{snapshot poweron}) {
+        @CALLS = ();
+        my ( $ok, $message ) = Trog::DataSource::Virt::act( $action, 'test:///default', 'alpha', 'specadmin' );
+        ok( $ok, "$action is still allowed on it" ) or diag($message);
+        is( scalar @CALLS, 1, 'and reached libvirt' );
+    }
+
+    # Its neighbours are ordinary guests.
+    @CALLS = ();
+    my ($ok) = Trog::DataSource::Virt::act( 'destroy', 'test:///default', 'beta', 'specadmin' );
+    ok( $ok, 'another guest on the same hypervisor is unaffected' );
+    is_deeply( \@CALLS, [ [ 'destroy', 'beta' ] ], 'and is destroyed as asked' );
+};
+
 subtest 'screenshot() validates its inputs before anything else' => sub {
     my $hv = { id => 'hv-1', conn_uri => 'test:///default' };
 
@@ -300,6 +370,52 @@ subtest 'guests show nothing an unprivileged viewer cannot use' => sub {
     }
 };
 
+subtest 'the server itself is drawn without the controls that would kill it' => sub {
+    require Text::Xslate;
+
+    my $tx = Text::Xslate->new(
+        path     => ["$FindBin::Bin/../www/templates/html/components"],
+        function => { render_it => sub { $_[0] } },
+    );
+
+    my %post = (
+        form    => 'guests.tx',
+        id      => 'uuid-alpha', title => 'alpha', state => 'running', is_active => 1,
+        preview => '/guest/screenshot/hv-1/alpha', domain => 'alpha',
+        hypervisor => 'hv-1', hypervisor_title => 'spec-hv', vcpus => 2,
+        addpost => 0, unreachable => 0,
+    );
+
+    foreach my $tiled ( 0, 1 ) {
+        my $view = $tiled ? 'tiled' : 'untiled';
+
+        my $me = $tx->render( 'forms/guests.tx',
+            { post => { %post, is_self => 1 }, style => '', route => '/vm', tiled => $tiled, can_edit => 1 } );
+        my $them = $tx->render( 'forms/guests.tx',
+            { post => { %post, is_self => 0 }, style => '', route => '/vm', tiled => $tiled, can_edit => 1 } );
+
+        # Said out loud, so an admin knows why this one is different.
+        like( $me, qr/dom0/, "$view: the guest we are running in says so" );
+        unlike( $them, qr/dom0/, "$view: and an ordinary guest does not" );
+    }
+
+    # Only the untiled view draws controls at all.
+    my $me = $tx->render( 'forms/guests.tx',
+        { post => { %post, is_self => 1 }, style => '', route => '/vm', tiled => 0, can_edit => 1 } );
+
+    foreach my $action (qw{poweroff destroy}) {
+        is( scalar( () = $me =~ m/value="\Q$action\E"/g ), 0, "no $action button for the server itself" );
+    }
+    is( scalar( () = $me =~ m/value="snapshot"/g ), 1, 'but it can still be snapshotted' );
+    like( $me, qr{action="/guest/act"}, 'and the form is still there to do it with' );
+
+    # A guest that is merely switched off must keep its Power On button -- the
+    # is_self guard wraps that branch too.
+    my $off = $tx->render( 'forms/guests.tx',
+        { post => { %post, is_self => 0, is_active => 0, state => 'shut off' }, style => '', route => '/vm', tiled => 0, can_edit => 1 } );
+    is( scalar( () = $off =~ m/value="poweron"/g ), 1, 'an ordinary stopped guest can still be started' );
+};
+
 subtest 'a datasource says whether its posts can be edited' => sub {
     require Trog::Routes::HTML;
 

www/styles/screen.css

@@ -453,7 +453,7 @@ pre {
     border-color: #400 #700 #700 #400;
 }
 
-a.tag {
+.tag {
     padding: 0rem .5rem 0rem .5rem;
     border-radius: 1rem;
     background: #e4e4e4;
@@ -505,3 +505,10 @@ a.tag {
     top: 3rem;
     right: 3rem;
 }
+
+.bg-green {
+    background-color: green;
+}
+.bg-red {
+    background-color: red;
+}

www/templates/html/components/forms/guests.tx

@@ -10,7 +10,10 @@
             : if ( $tiled ) {
                 <p class="midtitle">
                     <: $post.title :>
-                    <span class="guest-state guest-<: $post.is_active ? 'up' : 'down' :>"><: $post.state :></span>
+                    <span class="tag guest-state guest-<: $post.is_active ? 'up bg-green' : 'down bg-red' :>"><: $post.state :></span>
+                    : if ( $post.is_self ) {
+                    <span class="guest-state guest-self tag" title="the server tCMS is running on">dom0</span>
+                    : }
                 </p>
                 : # The capture is declared private in guests.json, so a reader
                 : # who cannot edit never receives it -- there is nothing here
@@ -23,7 +26,10 @@
             : } else {
                 <h3 class='blogtitles'>
                     <: $post.title :>
-                    <span class="guest-state guest-<: $post.is_active ? 'up' : 'down' :>"><: $post.state :></span>
+                    <span class="tag guest-state guest-<: $post.is_active ? 'up bg-green' : 'down bg-red' :>"><: $post.state :></span>
+                    : if ( $post.is_self ) {
+                    <span class="guest-state guest-self tag" title="the server tCMS is running on">dom0</span>
+                    : }
                 </h3>
                 <div class="postData responsive-text" id="postData-<: $post.id :>">
                     : if ( $post.preview ) {
@@ -39,14 +45,22 @@
                         <input type="hidden" name="hypervisor" value="<: $post.hypervisor :>" />
                         <input type="hidden" name="guest" value="<: $post.domain :>" />
                         <input type="hidden" name="to" value="<: $route :>" />
+                        : # This guest is the server drawing the page, so the two
+                        : # controls that would take it down are not offered.
+                        : # Trog::DataSource::Virt::act() refuses them too -- see
+                        : # there for why hiding them is not the guard.
+                        : if ( !$post.is_self ) {
                         : if ( $post.is_active ) {
                         <button class="coolbutton" type="submit" name="action" value="poweroff">Power Off</button>
                         : } else {
                         <button class="coolbutton" type="submit" name="action" value="poweron">Power On</button>
                         : }
+                        : }
                         <button class="coolbutton" type="submit" name="action" value="snapshot">Snapshot</button>
+                        : if ( !$post.is_self ) {
                         <button class="coolbutton guest-destroy" type="submit" name="action" value="destroy"
                                 onclick="return confirm('Destroy <: $post.title :>?  This stops the guest immediately.');">Destroy</button>
+                        : }
                     </form>
                     : }
                 </div>