#!/usr/bin/env perl

# Copyright (c) 2025, R. W. Rodolico
# 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,

# linux_havirt
# havirt (libvirt cluster tool) sensor. Reports this node and the guests running
# on it as havirt_node and havirt_domain (Documentation/Spec.md section 1.7).
#
# Revision History:
# 2026-10-13 Claude v1.0.0 initial havirt sensor
# 2026-10-18 Claude renamed from unix_havirt (bug 210)

package linux_havirt;

use strict;
use warnings;
use version;
our $VERSION = version->declare('v1.0.0');

use FindBin;
use File::Spec;
use lib File::Spec->catdir($FindBin::Bin), File::Spec->catdir("$FindBin::Bin/..");
use library qw(:all);

# where havirt is looked for after PATH (a variable so tests can change it)
our $fallbackHavirt = '/usr/local/bin/havirt';

#######################################################
#
# findHavirt()
#
# Locates the havirt executable: each PATH directory in
# order, then the fallback location.
#
# Parameters:
#   none
#
# Returns:
#   full path, or undef when not found
#
# Side Effects:
#   none
#
#######################################################
sub findHavirt {
   my @dirs = grep { defined($_) && length($_) } split(/:/, defined($ENV{'PATH'}) ? $ENV{'PATH'} : '');
   foreach my $dir (@dirs) {
      my $path = File::Spec->catfile($dir, 'havirt');
      return $path if -f $path && -x $path;
   }
   return $fallbackHavirt if -f $fallbackHavirt && -x $fallbackHavirt;
   return undef;
}

#######################################################
#
# hasHeader( $text )
#
# True when the first non-blank line of havirt TSV output
# is a header line (starts with the Node column).
#
# Parameters:
#   $text - havirt output
#
# Returns:
#   1 or 0
#
# Side Effects:
#   none
#
#######################################################
sub hasHeader {
   my $text = shift;
   return 0 unless defined($text);
   foreach my $line (split(/\n/, $text)) {
      next unless $line =~ /\S/;
      return $line =~ /^Node(?:\t|\s*$)/ ? 1 : 0;
   }
   return 0;
}

#######################################################
#
# parseTsvTable( $text )
#
# Parses havirt TSV output, reading columns by header name.
# In the extended domain list, NICs: and Disks: blocks of
# 4-space indented detail lines attach to the preceding
# summary row as nics (dev, bridge, mac) and disks (target,
# type, source). Unknown blocks are skipped.
#
# Parameters:
#   $text - havirt output
#
# Returns:
#   array reference of hash references (one per summary row)
#
# Side Effects:
#   none
#
#######################################################
sub parseTsvTable {
   my $text = shift;
   my @rows;
   my @header;
   my ($row, $block);
   foreach my $line (split(/\n/, defined($text) ? $text : '')) {
      $line =~ s/\r$//;
      next unless $line =~ /\S/;
      if (!@header) {
         @header = split(/\t/, $line, -1);
         next;
      }
      if ($line =~ /^\s+/) {
         next unless $row;
         # block start, e.g. "  NICs:"
         if ($line =~ /^\s{1,3}(\S+?):\s*$/) {
            $block = $1;
            next;
         }
         next unless defined($block) && $line =~ /^\s{4}/;
         (my $detail = $line) =~ s/^\s{4}//;
         my @f = split(/\t/, $detail, -1);
         if ($block eq 'NICs') {
            push @{$row->{'nics'}}, { 'dev' => $f[0], 'bridge' => $f[1], 'mac' => $f[2] };
         } elsif ($block eq 'Disks') {
            push @{$row->{'disks'}}, { 'target' => $f[0], 'type' => $f[1], 'source' => $f[2] };
         }
         next;
      }
      # summary row
      my @f = split(/\t/, $line, -1);
      $row = {};
      $block = undef;
      for (my $i = 0; $i < @header; $i++) {
         $row->{$header[$i]} = defined($f[$i]) ? $f[$i] : '';
      }
      $row->{'nics'} = [];
      $row->{'disks'} = [];
      push @rows, $row;
   }
   return \@rows;
}

#######################################################
#
# matchNode( $hostname, $nodeNames )
#
# Finds this host among havirt's node names: exact match
# first, then the first dot-separated label of each side,
# case-insensitively.
#
# Parameters:
#   $hostname  - output of hostname
#   $nodeNames - array reference of node names
#
# Returns:
#   the matching node name, or undef
#
# Side Effects:
#   none
#
#######################################################
sub matchNode {
   my ($hostname, $nodeNames) = @_;
   return undef unless defined($hostname) && length($hostname) && ref($nodeNames) eq 'ARRAY';
   foreach my $name (@{$nodeNames}) {
      return $name if defined($name) && $name eq $hostname;
   }
   my $short = lc((split(/\./, $hostname))[0]);
   foreach my $name (@{$nodeNames}) {
      next unless defined($name) && length($name);
      return $name if lc((split(/\./, $name))[0]) eq $short;
   }
   return undef;
}

#######################################################
#
# addLine( $out, @fields )
#
# Appends one tab-joined line unless its value (last field)
# is empty or undefined: an empty value would be dropped by
# the client's parser and turn the key into the value.
#
# Parameters:
#   $out    - array reference of lines
#   @fields - category, key path, value
#
# Returns:
#   nothing
#
# Side Effects:
#   appends to @$out
#
#######################################################
sub addLine {
   my ($out, @fields) = @_;
   return unless @fields >= 2;
   foreach my $field (@fields) {
      return unless defined($field) && length($field);
   }
   push @{$out}, join("\t", @fields);
}

#######################################################
#
# buildLines( $nodeRows, $domainRows, $nodeName )
#
# Builds the havirt_node and havirt_domain lines for one
# node and the guests running on it.
#
# Parameters:
#   $nodeRows   - parseTsvTable result of node list
#   $domainRows - parseTsvTable result of domain list --extended
#   $nodeName   - this node's Node value
#
# Returns:
#   array reference of sorted output lines
#
# Side Effects:
#   none
#
#######################################################
sub buildLines {
   my ($nodeRows, $domainRows, $nodeName) = @_;
   my @out;
   return \@out unless defined($nodeName);

   foreach my $node (@{$nodeRows || []}) {
      next unless defined($node->{'Node'}) && $node->{'Node'} eq $nodeName;
      addLine(\@out, 'havirt_node', 'name', $nodeName);
      foreach my $col (keys %{$node}) {
         next if $col eq 'Node' || ref($node->{$col});
         addLine(\@out, 'havirt_node', $col, $node->{$col});
      }
      last;
   }

   foreach my $dom (@{$domainRows || []}) {
      next unless defined($dom->{'Node'}) && $dom->{'Node'} eq $nodeName;
      my $name = $dom->{'Domain'};
      next unless defined($name) && length($name);
      foreach my $col (keys %{$dom}) {
         next if $col eq 'Node' || $col eq 'Domain' || ref($dom->{$col});
         addLine(\@out, 'havirt_domain', $name, $col, $dom->{$col});
      }
      foreach my $nic (@{$dom->{'nics'} || []}) {
         next unless defined($nic->{'mac'});
         addLine(\@out, 'havirt_domain', $name, 'nic', lc($nic->{'mac'}), $nic->{'bridge'});
      }
      foreach my $disk (@{$dom->{'disks'} || []}) {
         addLine(\@out, 'havirt_domain', $name, 'disk', $disk->{'target'}, 'type', $disk->{'type'});
         addLine(\@out, 'havirt_domain', $name, 'disk', $disk->{'target'}, 'source', $disk->{'source'});
      }
   }
   my @sorted = sort @out;
   return \@sorted;
}

#######################################################
#
# main()
#
# Runs hostname and two read-only havirt commands, prints
# this node's lines. Exit 1: no havirt / not a havirt node;
# exit 2: a command failed or printed no header.
#
# Parameters:
#   none
#
# Returns:
#   integer exit status
#
# Side Effects:
#   runs commands and writes STDOUT/STDERR
#
#######################################################
sub main {
   if (!checkOS({ 'linux' => undef })) {
      print STDERR "unsupported os\n";
      return 1;
   }
   my $havirt = findHavirt();
   if (!defined($havirt)) {
      print STDERR "havirt not found\n";
      return 2;
   }

   $? = 0;
   my $hostname = runCommand('hostname');
   if (($? >> 8) != 0 || !defined($hostname) || $hostname !~ /\S/) {
      print STDERR "hostname failed\n";
      return 4;
   }
   $hostname =~ s/^\s+|\s+$//g;

   $? = 0;
   my $nodeText = runCommand($havirt, 'node', 'list', '--format', 'tsv');
   if (($? >> 8) != 0 || !hasHeader($nodeText)) {
      print STDERR "havirt node list failed or printed no header\n";
      return 4;
   }
   $? = 0;
   my $domainText = runCommand($havirt, 'domain', 'list', '--extended', '--format', 'tsv');
   if (($? >> 8) != 0 || !hasHeader($domainText)) {
      print STDERR "havirt domain list failed or printed no header\n";
      return 4;
   }

   my $nodeRows = parseTsvTable($nodeText);
   my $nodeName = matchNode($hostname, [ map { $_->{'Node'} } @{$nodeRows} ]);
   if (!defined($nodeName)) {
      print STDERR "not a havirt node\n";
      return 2;
   }

   my $lines = buildLines($nodeRows, parseTsvTable($domainText), $nodeName);
   print join("\n", @{$lines}), "\n" if @{$lines};
   return 0;
}

exit main() unless caller;
1;