path: root/lex.cgi

#!/usr/bin/perl

use strict;
use warnings;
use Email::MIME;
use Fcntl qw(:flock);
use File::Spec;
use File::Find;
use File::Path qw(make_path);
use OpenBSD::Pledge;
use OpenBSD::Unveil;
use Time::HiRes qw(gettimeofday time);

my $start_time = time();

# Load Crypt::OpenPGP and all Crypt:: sub-modules before unveil()
BEGIN {
	require Crypt::OpenPGP;

	for my $inc_dir (@INC) {
		next unless -d $inc_dir;
		my $crypt_dir = File::Spec->catdir($inc_dir, 'Crypt');
		next unless -d $crypt_dir;

		find(sub {
			return unless /\.pm$/;
			my $rel = File::Spec->abs2rel($File::Find::name, $inc_dir);
			$rel =~ s/\.pm$//;
			my $module = join('::', File::Spec->splitdir($rel));
			eval "require $module;";
		}, $crypt_dir);
	}

	# Trigger backend instantiation (Math::BigInt, AutoLoader, Ciphers)
	eval {
		my $pgp = Crypt::OpenPGP->new();
	};
}

my $log_dir = "/var/log";
my $base_dir = "/var/lex";
my $spool_dir = "/var/lex/spool";
my $keyring_file = "$base_dir/pubring.gpg";

unveil("/dev/null", "rw") or die "unveil /dev/null failed: $!";
unveil($log_dir, "rwc") or die "unveil $base_dir failed: $!";
unveil($base_dir, "rwc") or die "unveil $base_dir failed: $!";
unveil() or die "unveil lock failed: $!";

pledge('stdio rpath wpath cpath flock') or die "pledge failed: $!";

my $dop = 5;
my $log_file = "$log_dir/lexcgi.log";
my $max_log_bytes = 1024 * 1024; # 1 MB cap

sub log_msg {
	my ($msg) = @_;

	my $lh;
	if (open($lh, '>>', $log_file)) {
		my $tz_offset = 8 * 3600;
		my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(time() + $tz_offset);
		my $timestamp = sprintf(
			"%04d-%02d-%02d %02d:%02d:%02d",
			$year + 1900, $mon + 1, $mday, $hour, $min, $sec
		);
		print $lh "[$timestamp] [$$] $msg\n";
		close($lh);
	}
}

sub respond_ok {
	print "Status: 200 OK\r\n";
	print "Content-Type: text/plain; charset=utf-8\r\n\r\n";
	print "OK\n";
	exit 0;
}

my $pgp_error;

sub set_pgp_error {
	my ($msg) = @_;
	$msg //= 'unknown error';
	$msg =~ s/\s+/ /g;   # collapse any newlines/whitespace runs to single spaces
	$msg =~ s/^\s+|\s+$//g; # trim leading/trailing space
	$pgp_error = $msg;
}

sub verify_pgp_signature {
	my ($signed_data, $signature) = @_;

	$pgp_error = undef;

	unless (-f $keyring_file) {
		set_pgp_error("No keyring at $keyring_file");
		return 0;
	}

	# Ensure CRLF line endings per OpenPGP canonical specification
	$signed_data =~ s/\r?\n/\r\n/g;

	my $pgp = Crypt::OpenPGP->new(
		PubRing => $keyring_file,
	);

	unless ($pgp) {
		set_pgp_error(Crypt::OpenPGP->errstr // 'unknown PGP init error');
		return 0;
	}

	my $verified = $pgp->verify(
		Data      => $signed_data,
		Signature => $signature,
	);

	unless ($verified) {
		set_pgp_error($pgp->errstr // 'unknown error');
	}

	return $verified ? 1 : 0;
}

sub acquire_lock {
	my ($max_slots) = @_;
	my $lock_dir = "$base_dir/locks";

	unless (-d $lock_dir) {
		make_path($lock_dir) or do {
			log_msg("ERROR: Failed to create lock dir $lock_dir: $!");
			return undef;
		};
	}

	for my $i (1 .. $max_slots) {
		my $slot_file = "$lock_dir/slot_$i.lock";
		my $fh;
		
		unless (open($fh, '>>', $slot_file)) {
			next;
		}

		if (flock($fh, LOCK_EX | LOCK_NB)) {
			return $fh;
		}
		close($fh);
	}

	return undef; # All slots full
}

my $lock_fh = acquire_lock($dop);
unless ($lock_fh) {
	log_msg("WARN: Concurrency limit ($dop) reached. Dropping request.");
	respond_ok();
}

my $content_type   = $ENV{'CONTENT_TYPE'} // '';
my $content_length = $ENV{'CONTENT_LENGTH'} // 0;

my $remote_ip  = $ENV{'REMOTE_ADDR'} // 'unknown';
my $user_agent = $ENV{'HTTP_USER_AGENT'} // 'unknown';
log_msg("INFO: New request from $remote_ip [$user_agent]");

unless ($content_length > 0) {
	log_msg("WARN: content_length is 0 or missing");
	respond_ok();
}

binmode(STDIN);
my $raw_data = '';
read(STDIN, $raw_data, $content_length);

unless ($content_type =~ /application\/x-www-form-urlencoded/i) {
	log_msg("WARN: Content-Type is not urlencoded: '$content_type'");
	respond_ok();
}

my %params;
for my $pair (split(/&/, $raw_data)) {
	my ($key, $val) = split(/=/, $pair, 2);
	next unless defined $key;

	$key =~ tr/+/ /;
	$key =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/eg;

	$val //= '';
	$val =~ tr/+/ /;
	$val =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/eg;

	$params{$key} //= $val;
}

my $mime_raw = $params{'body-mime'} // '';
if ($mime_raw eq '') {
	log_msg("WARN: No MIME message in payload");
	respond_ok();
}

# Parse MIME message
my $parsed = Email::MIME->new($mime_raw);
my @parts  = $parsed->parts;

unless (@parts >= 2) {
	log_msg("WARN: MIME parts count < 2 (found " . scalar(@parts) . ")");
	respond_ok();
}

# Extract the boundary string from the outer Content-Type header so the
# signed part can be sliced out of the raw message verbatim. PGP/MIME
# signature verification (RFC 3156) requires the exact original octets of
# the signed entity; re-serializing it via Email::MIME's ->as_string()
# is not safe, since header folding, whitespace, and field order can be
# normalized differently on reserialization than the sender produced,
# which breaks the signature hash even though the content is unchanged.
my ($boundary) = $parsed->content_type =~ /boundary="?([^";]+)"?/;

unless ($boundary) {
	log_msg("WARN: No MIME boundary found in Content-Type header");
	respond_ok();
}

# Slice the literal bytes between the first boundary delimiter and the
# CRLF immediately preceding the second boundary delimiter. That trailing
# CRLF belongs to the boundary line itself, not the signed content, per
# the MIME multipart spec.
my $signed_part;
if ($mime_raw =~ /--\Q$boundary\E\r?\n(.*?)\r?\n--\Q$boundary\E/s) {
	$signed_part = $1;
	$signed_part =~ s/\r?\n/\r\n/g; # canonical OpenPGP line endings
}

# Extract PGP signature block
my $sig_part_raw = $parts[1]->body_raw // '';
my ($pgp_sig)    = $sig_part_raw =~ /(-----BEGIN PGP SIGNATURE-----[\s\S]*?-----END PGP SIGNATURE-----)/;

unless ($pgp_sig) {
	my $sig_part_str = $parts[1]->body_str // '';
	($pgp_sig) = $sig_part_str =~ /(-----BEGIN PGP SIGNATURE-----[\s\S]*?-----END PGP SIGNATURE-----)/;
}

unless (defined $signed_part && length($signed_part) > 0 && $pgp_sig) {
	log_msg("WARN: Missing PGP signature block");
	respond_ok();
}

unless (verify_pgp_signature($signed_part, $pgp_sig)) {
	log_msg("WARN: PGP signature verification failed: " . ($pgp_error // 'unknown error'));
	respond_ok();
}

my $plain_text = $parts[0]->body_str // '';
$plain_text =~ s/\r\n/\n/g;
$plain_text =~ s/\n-- \n.*$//s;
$plain_text =~ s/^\s+|\s+$//g;

my $plain_text_len = length($plain_text);

unless ($plain_text_len > 0) {
	log_msg("WARN: Message is empty after stripping");
	respond_ok();
}

unless ($plain_text_len <= 200) {
	log_msg("WARN: Message exceeds 200 characters");
	respond_ok();
}

my ($sec, $usec) = gettimeofday();
my $spool_filename = sprintf("spool_%d%06d_%d.job", $sec, $usec, $$);
my $tmp_spool_file = "$spool_dir/tmp/$spool_filename.tmp";
my $spool_file = "$spool_dir/new/$spool_filename";

# Set umask so group gets read/write (0666 & ~0007 = 0660)
my $old_umask = umask(007);
my $sfh;
unless (open($sfh, '>:utf8', $tmp_spool_file)) {
	umask($old_umask);
	log_msg("ERROR: Failed to create $tmp_spool_file: $!");
	respond_ok();
}

print $sfh $plain_text . "\n";
close($sfh);

unless (rename($tmp_spool_file, $spool_file)) {
	umask($old_umask);
	log_msg("ERROR: Failed to create $spool_file: $!");
	respond_ok();
}

umask($old_umask);

my $elapsed_ms = sprintf("%.2fms", (time() - $start_time) * 1000);
my $msg_id = sprintf("msg_%.6f_$$", time());
my $content_length_kb = sprintf("%.2f KB", $content_length / 1024);

log_msg("INFO: Processed $msg_id ($content_length_kb) in $elapsed_ms");
respond_ok();