#!/usr/bin/perl
use strict;
use warnings;
use Fcntl qw(:DEFAULT :flock :mode);
use File::Temp qw(tempfile);
use IO::Select;
use JSON::PP;
use POSIX qw(setsid WNOHANG);
use Time::HiRes qw(time sleep);

my $json = JSON::PP->new->utf8->canonical;
my @commands = (
    ['uname', '/usr/bin/uname', '-a'],
    ['kern.version', '/usr/sbin/sysctl', 'kern.version'],
    ['bsd.version', '/usr/bin/what', '/bsd'],
    ['syspatch', '/usr/sbin/syspatch', '-l'],
    ['packages', '/usr/sbin/pkg_info', '-q'],
    ['packages.paths', '/usr/sbin/pkg_info', '-aP'],
    ['ntp', '/usr/sbin/ntpctl', '-s', 'status'],
    ['architecture', '/usr/bin/machine', '-a'],
    ['installed.SHA256', '/bin/cat', '/var/db/installed.SHA256'],
    ['installed.BUILDINFO', '/bin/cat', '/var/db/installed.BUILDINFO'],
);

sub fqdn {
    my ($name) = @_;
    $name = lc $name;
    $name =~ s/\.$//;
    die "invalid fqdn\n" if length($name) > 253 || $name !~ /\./;
    for my $label (split /\./, $name, -1) {
        die "invalid fqdn\n" unless $label =~ /\A[a-z0-9](?:[a-z0-9-]{0,61}[a-z0-9])?\z/;
    }
    return $name;
}

sub private_read {
    my ($path, $limit) = @_;
    sysopen(my $fh, $path, O_RDONLY | O_NOFOLLOW) or die "open $path: $!\n";
    my @st = stat $fh;
    die "unsafe permissions: $path\n" unless S_ISREG($st[2]) && $st[4] == 0 && ($st[2] & 077) == 0;
    my $n = read($fh, my $data, $limit + 1);
    die "read $path: $!\n" unless defined $n;
    die "file too large: $path\n" if $n > $limit;
    close $fh or die "close $path: $!\n";
    return $data;
}

sub config {
    my ($path) = @_;
    my %c;
    for my $line (split /\n/, private_read($path, 8192)) {
        next if $line =~ /\A\s*(?:#.*)?\z/;
        die "invalid config line\n" unless $line =~ /\A([a-z_]+)=(\S+)\z/;
        die "duplicate config key\n" if exists $c{$1};
        $c{$1} = $2;
    }
    my %allowed = map { $_ => 1 } qw(server fqdn state_dir bootstrap_file);
    die "unknown config key\n" if grep { !$allowed{$_} } keys %c;
    die "missing server, fqdn or state_dir\n" unless $c{server} && $c{fqdn} && $c{state_dir};
    die "invalid server URL\n" unless $c{server} =~ m{\Ahttps://([a-zA-Z0-9.-]+)(?::([0-9]{1,5}))?/?\z};
    my ($host, $port) = ($1, $2);
    $c{host} = fqdn($host);
    $c{port} = defined($port) ? 0 + $port : 443;
    die "invalid port\n" unless $c{port} >= 1 && $c{port} <= 65535;
    $c{fqdn} = fqdn($c{fqdn});
    die "state_dir must be absolute\n" unless $c{state_dir} =~ m{\A/};
    return \%c;
}

sub run_command {
    my ($argv, $input, $dir, $timeout, $limit) = @_;
    my ($in, $in_path) = tempfile('input.XXXXXXXX', DIR => $dir, UNLINK => 1);
    binmode $in;
    print {$in} $input or die "write input: $!\n";
    seek($in, 0, 0) or die "seek input: $!\n";
    pipe(my $out_r, my $out_w) or die "pipe: $!\n";
    pipe(my $err_r, my $err_w) or die "pipe: $!\n";
    my $pid = fork;
    die "fork: $!\n" unless defined $pid;
    if (!$pid) {
        setsid() >= 0 or POSIX::_exit(126);
        open(STDIN, '<&', $in) or POSIX::_exit(126);
        open(STDOUT, '>&', $out_w) or POSIX::_exit(126);
        open(STDERR, '>&', $err_w) or POSIX::_exit(126);
        close $out_r; close $err_r; close $out_w; close $err_w; close $in;
        exec { $argv->[0] } @$argv or POSIX::_exit(127);
    }
    close $in; close $out_w; close $err_w;
    my $select = IO::Select->new($out_r, $err_r);
    my %buffers = (fileno($out_r) => '', fileno($err_r) => '');
    my ($out_fd, $err_fd) = (fileno($out_r), fileno($err_r));
    my $deadline = time + $timeout;
    my $failure;
    while ($select->count) {
        if (time >= $deadline) { $failure = 'timeout'; last; }
        for my $fh ($select->can_read(0.1)) {
            my $n = sysread($fh, my $buf, 8192);
            if (!defined $n) { next if $!{EINTR}; $failure = 'read failure'; last; }
            if (!$n) { $select->remove($fh); close $fh; next; }
            my $fd = fileno $fh;
            $buffers{$fd} .= $buf;
            if (length($buffers{$fd}) > $limit) {
                $buffers{$fd} = substr($buffers{$fd}, 0, $limit);
                $failure = 'output limit; command output truncated'; last;
            }
        }
        last if $failure;
    }
    # A child may close its output before it exits.
    unless ($failure) {
        while (waitpid($pid, WNOHANG) == 0) {
            if (time >= $deadline) { $failure = 'timeout'; last; }
            sleep 0.02;
        }
    }
    my $status = $?;
    if ($failure) {
        kill 'KILL', -$pid;
        kill 'KILL', $pid;
        waitpid($pid, 0);
        $buffers{$err_fd} .= "\npatchouli: $failure\n";
    }
    for my $fh ($select->handles) { close $fh; }
    unlink $in_path;
    return {stdout => $buffers{$out_fd}, stderr => $buffers{$err_fd},
        exit_code => $failure ? 124 : ($status & 127 ? 128 + ($status & 127) : $status >> 8)};
}

sub response {
    my ($raw) = @_;
    my ($head, $body) = split /\r\n\r\n/, $raw, 2;
    die "invalid HTTP response\n" unless defined($body) && $head =~ /\AHTTP\/1\.[01] ([0-9]{3})[^\r\n]*\r?\n?/;
    my $status = 0 + $1;
    my @lines = split /\r\n/, $head;
    shift @lines;
    my %headers;
    for my $line (@lines) {
        die "invalid HTTP header\n" unless $line =~ /\A([A-Za-z0-9-]+):[ \t]*(.*?)\z/;
        my ($key, $value) = (lc($1), $2);
        die "duplicate HTTP header\n" if exists $headers{$key};
        $headers{$key} = $value;
    }
    if (exists $headers{'transfer-encoding'}) {
        die "unsupported transfer encoding\n" unless lc($headers{'transfer-encoding'}) eq 'chunked' && !exists $headers{'content-length'};
        my $decoded = '';
        while (1) {
            die "invalid chunk\n" unless $body =~ s/\A([0-9a-fA-F]{1,8})\r\n//;
            my $n = hex $1;
            if (!$n) { die "invalid chunk trailer\n" unless $body eq "\r\n"; last; }
            die "short chunk\n" unless length($body) >= $n + 2 && substr($body, $n, 2) eq "\r\n";
            $decoded .= substr($body, 0, $n, '');
            substr($body, 0, 2, '');
        }
        $body = $decoded;
    } elsif (exists $headers{'content-length'}) {
        die "invalid response length\n" unless $headers{'content-length'} =~ /\A[0-9]+\z/ && length($body) == $headers{'content-length'};
    }
    return ($status, $body);
}

sub post {
    my ($c, $path, $key, $data) = @_;
    die "invalid credential\n" unless $key =~ /\A[A-Za-z0-9_-]{20,256}\z/;
    my $body = $json->encode($data);
    die "report exceeds 4 MiB limit\n" if length($body) > 4194304;
    my $request = "POST $path HTTP/1.0\r\nHost: $c->{host}:$c->{port}\r\n" .
        "Authorization: Bearer $key\r\nContent-Type: application/json\r\n" .
        'Content-Length: ' . length($body) . "\r\nConnection: close\r\n\r\n$body";
    my $r = run_command(['/usr/bin/nc', '-c', '-e', $c->{host}, '-w', '20', $c->{host}, $c->{port}],
        $request, $c->{state_dir}, 30, 65536);
    die "HTTPS transport failed (exit $r->{exit_code})\n" if $r->{exit_code};
    return response($r->{stdout});
}

sub main {
    die "must run as root\n" unless $> == 0;
    umask 077;
    %ENV = (PATH => '/bin:/sbin:/usr/bin:/usr/sbin', LC_ALL => 'C');
    my ($register, $jitter, $config) = (0, 0, '/etc/patchouli-reporter.conf');
    while (@ARGV) {
        my $arg = shift @ARGV;
        if ($arg eq '--register') { $register = 1; }
        elsif ($arg eq '--jitter') { $jitter = 1; }
        elsif ($arg eq '--config' && @ARGV) { $config = shift @ARGV; }
        else { die "usage: patchouli-reporter [--config file] [--register] [--jitter]\n"; }
    }
    my $c = config($config);
    my @st = lstat $c->{state_dir};
    die "state_dir must be a root-owned 0700 directory\n" unless @st && S_ISDIR($st[2]) && $st[4] == 0 && ($st[2] & 0777) == 0700;
    sysopen(my $lock, "$c->{state_dir}/lock", O_WRONLY | O_CREAT | O_NOFOLLOW, 0600) or die "open lock: $!\n";
    flock($lock, LOCK_EX | LOCK_NB) or die "reporter already running\n";
    sleep int(rand(121)) if $jitter;
    my $state = "$c->{state_dir}/credential.json";
    if ($register) {
        die "local credential exists; registration refused\n" if lstat $state;
        die "bootstrap_file is required\n" unless $c->{bootstrap_file};
        my $key = private_read($c->{bootstrap_file}, 1024);
        $key =~ s/\n\z//;
        my ($status, $body) = post($c, '/v1/register', $key, {fqdn => $c->{fqdn}});
        die "registration rejected: HTTP $status\n" unless $status == 201;
        my $credential = eval { $json->decode($body) };
        die "invalid registration response\n" unless ref($credential) eq 'HASH' && ($credential->{fqdn} // '') eq $c->{fqdn} && ($credential->{key} // '') =~ /\A[A-Za-z0-9_-]{20,256}\z/;
        my ($fh, $temp) = tempfile('credential.XXXXXXXX', DIR => $c->{state_dir}, UNLINK => 1);
        print {$fh} $json->encode($credential), "\n" or die "write credential: $!\n";
        close $fh or die "close credential: $!\n";
        rename($temp, $state) or die "rename credential: $!\n";
        print "registered $c->{fqdn}\n";
        return;
    }
    my $credential = $json->decode(private_read($state, 4096));
    die "credential fqdn mismatch\n" unless ref($credential) eq 'HASH' && ($credential->{fqdn} // '') eq $c->{fqdn};
    my %results;
    for my $command (@commands) {
        my ($name, @argv) = @$command;
        my $result = run_command(\@argv, '', $c->{state_dir}, 15, 65536);
        # Command bytes outside UTF-8 remain visible as replacement characters.
        for my $stream (qw(stdout stderr)) {
            require Encode;
            $result->{$stream} = Encode::decode('UTF-8', $result->{$stream}, Encode::FB_DEFAULT());
        }
        $results{$name} = $result;
    }
    my ($status) = post($c, '/v1/report', $credential->{key},
        {fqdn => $c->{fqdn}, os => 'OpenBSD', commands => \%results});
    die "report rejected: HTTP $status\n" unless $status >= 200 && $status < 300;
}

unless (caller) {
    eval { main(); 1 } or do { my $error = $@ || "report failed\n"; print STDERR $error; exit 1; };
}
1;