#! /usr/local/bin/perl -w

# The Emergency Daemon - wait for simple emergency commands and execute them

# David A. Madore <URL: http://www.madore.org/~david/ > - Public Domain

# *** The emergency daemon protocol ***
#
# Commands are sent through UDP datagrams, normally addressed to port
# 911.  Commands consist of three parts separated or terminated by '|'
# or \n (but \r\n is also accepted).  First part is the command
# proper.  Second is a UTC timestamp in yyyy-mm-ddThh:mm:ssZ format
# (here 'T' and 'Z' are literal 'T' and 'Z').  Third is the
# HMAC-SHA256, in hexadecimal, of command|timestamp (separated by '|',
# even if they were separated differently in the input, and not
# terminated by anything), with a HMAC key shared by client and
# server.
#
# The server response consists of one or more lines terminated by \n.
# If the command is PING, the server responds PONG.  If the command is
# DATE, the server responds DATE followed by the current time and the
# timestamp of the last authenticated command.  Apart from PING and
# DATE, all other commands are authenticated: if the HMAC does not
# match what it should be, the server responds !MAC.  If the timestamp
# does not match the current date +/- 30 seconds, the server responds
# !DAT; it also does so if the timestamp is not (strictly) greater
# than the timestamp of the last request.
#
# The NOOP command does nothing (but must still be authenticated): the
# server responds NOOP.  The DPID command returns the daemon's PID:
# the server responds DPID and then the PID itself (on a separate
# line).  The DIE! command causes the daemon to respond BYE! and then
# quit.  The RKEY command causes the daemon to reread its key file:
# the server responds either DONE or !ERR in case of error, in which
# case the next line in the response is a human-readable error line.
# The LOGM command is followed by whitespace, an optional priority (as
# in the LOG_* syslog macros: WARNING, DEBUG, etc.; again followed by
# whitespace), and a message to be written to syslog: the server
# responds DONE.  The SYRQ command is followed by whitespace and then
# by data to be written to /proc/sysrq-trigger: the server responds
# either DONE or !ERR in case of error, in which case the next line in
# the response is a human-readable error line.

# *** The emergency daemon itself ***
#
# The daemon understands three options:
#
# -p <number> indicates which port it should bind to.  The daemon
# binds to the IPv6 unspecified address with the IPV6_V6ONLY option
# set to 0, thus listening on both IPv6 and IPv4 families.
#
# -k <filename> specifies the key file to use.  This file contains one
# or more keys, one per line, which will all be equally valid when
# computing the MAC.
#
# -f requests that the daemon ignore HUP and INT signals, and fork
# once it has successfully set up its listening socket: the father
# then prints its child's PID and exits successfully.

use strict;
use warnings;
use Digest::SHA qw(hmac_sha256_hex);
use Socket;
use Socket6;
use POSIX ();
use Sys::Syslog qw(:standard :macros);
use Getopt::Std;

use constant {
    DEFAULT_PORT => 911,
    SYSLOG_IDENT => "emergencyd.pl"
};

my %opts;

getopts("k:p:f", \%opts);

my @authorized_keys;

my $key_filename = $opts{k};
die "No key file specified (use -k option)" unless defined($key_filename);
sub read_keys {
    open my $key_file, "<", $key_filename
	or die "Cannot open key file $opts{k}: $!";
    @authorized_keys = ();
    while (<$key_file>) {
	chomp;
	push @authorized_keys, $_;
    }
    close $key_file;
}
read_keys;

my $proto = getprotobyname("udp") or die "Can't resolve udp protocol: $!";
my $port;
if ( defined($opts{p}) ) {
    $port = $opts{p};
    $port =~ /^\d+$/ or die "Invalid port number (-p option) $port";
} else {
    $port = DEFAULT_PORT;
}

socket my $socket, PF_INET6, SOCK_DGRAM, $proto
    or die "Can't create socket: $!";
if ( defined(*IPV6_V6ONLY{CODE}) ) {
    setsockopt $socket, IPPROTO_IPV6, IPV6_V6ONLY, 0
	or die "Can't set IPV6_V6ONLY option to 0: $!";
}
bind $socket, sockaddr_in6($port, in6addr_any) or die "Can't bind socket: $!";

openlog(SYSLOG_IDENT, "ndelay,pid", LOG_DAEMON);

if ( $opts{f} ) {
    chdir("/");
    open STDIN, "/dev/null";
    $SIG{HUP} = "IGNORE";
    $SIG{INT} = "IGNORE";
    my $childpid = fork;
    die "Can't fork: $!" unless defined($childpid);
    if ( $childpid ) {
	print "$childpid\n";
	exit 0;
    }
    close STDOUT;
    close STDERR;
    POSIX::setsid;
}

sub curtime {
    my $fiddle = shift // 0;
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
	= gmtime(time+$fiddle);
    return sprintf("%04d-%02d-%02dT%02d:%02d:%02dZ",
		   $year+1900,$mon+1,$mday,$hour,$min,$sec);
}

sub check_mac {
    my $cmdline = shift;
    my $timestamp = shift;
    my $mac_check = shift; 
    my $validate = "$cmdline|$timestamp";
    my $mac_checked = 0;
    foreach my $key ( @authorized_keys ) {
	if ( $mac_check eq hmac_sha256_hex($validate, $key) ) {
	    return 1;
	}
    }
    return 0;
}

my $mintime = "0";

my $running = 1;

sub check_and_update_timestamp {
    my $timestamp = shift;
    if ( ($timestamp ge curtime(-30)) && ($timestamp le curtime(30))
	 && ($timestamp gt $mintime) ) {
	$mintime = $timestamp;
	return 1;
    }
    return 0;
}

sub cmd_ping {
    return "PONG\n";
}

sub cmd_date {
    return [ "DATE", curtime, $mintime ];
}

sub cmd_noop {
    return "NOOP\n";
}

sub cmd_dpid {
    return [ "DPID" , $$ ];
}

sub cmd_die {
    $running = 0;
    return "BYE!\n";
}

sub cmd_rkey {
    read_keys;
    return "DONE\n";
}

sub cmd_logm {
    my $s = shift or die "Missing argument to LOGM\n";
    my $level = LOG_NOTICE;
    my %levels = ("EMERG"=>LOG_EMERG, "ALERT"=>LOG_ALERT,
		  "CRIT"=>LOG_CRIT, "ERR"=>LOG_ERR, "WARNING"=>LOG_WARNING,
		  "NOTICE"=>LOG_NOTICE, "INFO"=>LOG_INFO, "DEBUG"=>LOG_DEBUG);
    if ( $s =~ /^([A-Z0-9]*)\s+(.*)/ && exists($levels{$1}) ) {
	$level = $levels{$1};
	$s = $2;
    }
    syslog $level, $s;
    return "DONE\n";
}

sub cmd_syrq {
    my $s = shift or die "Missing argument to SYRQ\n";
    open my $sysrq_trigger, ">", "/proc/sysrq-trigger"
	or die "Couldn't open /proc/sysrq-trigger for writing: $!";
    print $sysrq_trigger $s
	or die "Couldn't write to /proc/sysrq-trigger: $!";
    close $sysrq_trigger;
    return "DONE\n";
}

my %dispatch = (
    "PING" => \&cmd_ping,
    "DATE" => \&cmd_date,
    "NOOP" => \&cmd_noop,
    "DPID" => \&cmd_dpid,
    "DIE!" => \&cmd_die,
    "RKEY" => \&cmd_rkey,
    "LOGM" => \&cmd_logm,
    "SYRQ" => \&cmd_syrq,
  );

PACKET:
while ( $running ) {
    my $buf;
    my $sender = recv($socket, $buf, 16384, 0);
    die "Failed to receive packet: $!" unless defined($sender);
    my @lines = split /\015*\012|\|/s, $buf;
    my $cmdline = $lines[0] // "";
    my $timestamp = $lines[1] // "";
    my $mac_check = $lines[2] // "";
    next PACKET if $cmdline eq "";
    my $resp = undef;
    eval {
	my ($command, $arg) = $cmdline =~ /^([A-Z0-9\!]{4})(?:\s+(.*))?$/
	    or die "!BAD\n";
	unless ( $command eq "PING" || $command eq "DATE" ) {
	    check_mac $cmdline, $timestamp, $mac_check
		or die "!MAC\n";
	    check_and_update_timestamp $timestamp
		or die "!DAT\n";
	}
	my $sub = $dispatch{$command};
	die "!UNK\n" unless defined($sub);
	$resp = &{$sub}($arg);
    };
    if ( $@ ) {
	$resp = $@;
	if ( ref($resp) eq "" && $resp !~ /^\!/ ) {
	    $resp = "!ERR\n" . $resp;
	}
    }
    if ( defined($resp) ) {
	$resp = join("\n", @{$resp}) . "\n" if ref($resp) eq "ARRAY";
	send $socket, $resp, 0, $sender;
    }
}
exit 0;