path: root/mailer.pl

#!/usr/bin/perl
use strict;
use warnings;
use utf8;
use Time::Piece;
use Sys::Syslog qw(:standard :macros);
use Socket qw(AF_UNIX SOCK_STREAM PF_UNSPEC);
use OpenBSD::Pledge;
use OpenBSD::Unveil;

my $dict_dir    = '/var/www/var/lex/dict';
my $state_file  = '/var/www/var/lex/mailer.tsv';
my $to          = 'me@example.com';
my $from        = 'lex@example.com';
my $from_header = "Lex <$from>";
my $subject     = 'Daily word';
my $sendmail    = '/usr/sbin/sendmail';
my $syslog_tag  = 'lex-mail';

my $max_interval = 365; # Upper bound limit (1 year)
my $timeout_sec  = 30;  # Execution timeout for child/sendmail

# Connect to syslog before pledge/unveil
openlog($syslog_tag, 'ndelay,pid', LOG_MAIL);

sub log_die {
	my ($msg) = @_;
	syslog(LOG_ERR, "%s", $msg);
	closelog();
	die $msg;
}

# Socket pair for parent/child IPC
socketpair(my $parent_sock, my $child_sock, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
	or log_die("socketpair failed: $!");

my $pid = fork();
log_die("fork failed: $!") unless defined $pid;

if ($pid == 0) {
	# Child process for handling mail pipe
	close($parent_sock);

	# 'exec' no longer exposed to parent proc
	pledge(qw(stdio proc exec)) or die "child pledge failed";

	# Read email message from socket
	my $raw_email;
	{
		local $/;
		$raw_email = <$child_sock>;
	}
	close($child_sock);

	if (!$raw_email) {
		exit 0; # Parent aborted or sent no mail
	}

	open(my $mail_pipe, '|-', $sendmail, '-i', '-f', $from, $to)
		or die "child failed to exec $sendmail: $!";

	binmode($mail_pipe, ':utf8');
	print $mail_pipe $raw_email;

	if (!close($mail_pipe)) {
		my $status   = $?;
		my $exit_val = $status >> 8;
		my $sig_num  = $status & 127;
		if ($sig_num) {
			die "sendmail killed by signal $sig_num";
		}
		die "sendmail exited with status $exit_val";
	}

	exit 0;
}

# Parent process: spaced-repetition + fair scheduling
close($child_sock);

unveil($dict_dir, 'r') or log_die("unveil $dict_dir: $!");
unveil($state_file, 'rwc') or log_die("unveil $state_file: $!");
unveil('/dev/log', 'w') or log_die("unveil /dev/log: $!");
unveil(); # Lock unveil rules

# Main process drops 'exec'
pledge(qw(stdio rpath wpath cpath proc)) or log_die("parent pledge: $!");

# Read dictionary files 
my $dh;
if (!opendir($dh, $dict_dir)) {
	log_die("Cannot open $dict_dir: $!");
}
my @current_files = grep { -f "$dict_dir/$_" && !/^\./ } readdir($dh);
closedir($dh);

if (!@current_files) {
	syslog(LOG_WARNING, "No files found in %s", $dict_dir);
	if (-f $state_file) {
		if (open(my $clear_fh, '>', $state_file)) {
			close($clear_fh);
		} else {
			syslog(LOG_ERR, "Failed to clear %s: %s", $state_file, $!);
		}
	}
	close($parent_sock);
	waitpid($pid, 0);
	closelog();
	exit 0;
}

my %active_files = map { $_ => 1 } @current_files;
my %state;
my $today = localtime->ymd;

if (-f $state_file) {
	my $sfh;
	if (!open($sfh, '<', $state_file)) {
		log_die("Cannot open $state_file: $!");
	}
	while (my $line = <$sfh>) {
		chomp $line;
		next if $line =~ /^\s*$/;
		my ($file, $next_due, $interval, $reviews, $factor) = split(/\t/, $line);
		
		if ($file && $active_files{$file}) {
			$state{$file} = {
				next_due => $next_due  // $today,
				interval => $interval  // 1,
				reviews  => $reviews   // 0,
				factor   => $factor    // 2.5,
			};
		}
	}
	close($sfh);
}

# Initialize new files
foreach my $file (@current_files) {
	if (!$state{$file}) {
		$state{$file} = {
			next_due => $today,
			interval => 1,
			reviews  => 0,
			factor   => 2.5,
		};
	}
}

# Candidate selection (spaced repetition + fair scheduling)
my @due_files = grep { $state{$_}{next_due} le $today } @current_files;

my $selected_file;
if (@due_files == 1) {
	$selected_file = $due_files[0];
} elsif (@due_files > 1) {
	my %weights;
	my $total_weight = 0;
	
	foreach my $file (@due_files) {
		my $w = 1.0 / ($state{$file}{reviews} + 1);
		$weights{$file} = $w;
		$total_weight += $w;
	}

	# Weighted random selection (roulette wheel algorithm)
	# Higher weight = larger target segment = higher probability of selection
	my $rand_point = rand($total_weight);
	my $accum = 0;
	foreach my $file (@due_files) {
		$accum += $weights{$file};
		if ($rand_point <= $accum) {
			$selected_file = $file;
			last;
		}
	}

	# Guard against IEEE 754 floating-point rounding edge cases at boundary
	$selected_file //= $due_files[-1];
} else {
	@current_files = sort { $state{$a}{next_due} cmp $state{$b}{next_due} } @current_files;
	$selected_file = $current_files[0];
	syslog(LOG_INFO, "No files due today; falling back to nearest due file: %s", $selected_file);
}

# Read candidate file content
my $file_path = "$dict_dir/$selected_file";
my $fh;
if (!open($fh, '<:utf8', $file_path)) {
	log_die("Cannot open $file_path: $!");
}
my $body;
{
	local $/; # slurp mode
	$body = <$fh>;
}
close($fh);

# Construct payload and send to helper process over socket
my $email_data = "From: $from_header\n"
               . "To: $to\n"
               . "Subject: $subject - $selected_file\n"
               . "Content-Type: text/plain; charset=UTF-8\n\n"
               . $body;

binmode($parent_sock, ':utf8');
print $parent_sock $email_data;
close($parent_sock);

# Wait for child execution to complete
eval {
	local $SIG{ALRM} = sub { die "TIMEOUT\n" };
	alarm($timeout_sec);

	waitpid($pid, 0);

	alarm(0);
};

if ($@) {
	if ($@ eq "TIMEOUT\n") {
		kill('KILL', $pid);
		log_die("Mailer child process timed out after ${timeout_sec}s");
	} else {
		log_die("Error waiting for mailer child process: $@");
	}
}

if ($? != 0) {
	my $status   = $?;
	my $exit_val = $status >> 8;
	my $sig_num  = $status & 127;

	if ($sig_num) {
		log_die("Mailer child process killed by signal $sig_num");
	} else {
		log_die("Mailer child process exited with status $exit_val");
	}
}

# Update schedule state
my $item     = $state{$selected_file};
my $interval = $item->{interval};
my $factor   = $item->{factor};

if ($item->{reviews} == 0) {
	$interval = 1;
} elsif ($item->{reviews} == 1) {
	$interval = 6;
} else {
	$interval = int($interval * $factor);
}

if ($interval > $max_interval) {
	$interval = $max_interval;
}

$item->{interval} = $interval;
$item->{reviews} += 1;

my $now = localtime;
$item->{next_due} = ($now + ($interval * 86400))->ymd;

# Cleanup deleted items
foreach my $file (keys %state) {
	delete $state{$file} unless $active_files{$file};
}

# Atomic write update
my $tmp_file = "$state_file.tmp";
my $out_fh;
if (!open($out_fh, '>', $tmp_file)) {
	log_die("Cannot write to $tmp_file: $!");
}
foreach my $file (keys %state) {
	my $i = $state{$file};
	print $out_fh join("\t", $file, $i->{next_due}, $i->{interval}, $i->{reviews}, $i->{factor}), "\n";
}
close($out_fh) or log_die("Error closing $tmp_file: $!");

if (!rename($tmp_file, $state_file)) {
	log_die("Cannot atomic swap $tmp_file to $state_file: $!");
}

syslog(LOG_INFO, "Mailed %s to %s (next due: %s)", $selected_file, $to, $item->{next_due});
closelog();