#!/usr/bin/env perl

# Copyright (c) 2015-2021 Christian Jaeger, copying@christianjaeger.ch
# This is free software. See the file COPYING.md that came bundled
# with this file.

use strict;
use warnings;
use warnings FATAL => 'uninitialized';
use experimental "signatures";

# find modules from functional-perl working directory (not installed)
use Cwd 'abs_path';
our ($mydir, $myname);

BEGIN {
    my $location = (-l $0) ? abs_path($0) : $0;
    $location =~ /(.*?)([^\/]+?)_?\z/s or die "?";
    ($mydir, $myname) = ($1, $2);
}
use lib "$mydir/../lib";

sub usage {
    print STDERR map {"$_\n"} @_ if @_;
    print "$myname file(s)

  Hack to prepare an outgoing mail file (as saved in a Maildir) for
  sending through 'sendmail -t'. It simply removes and adds some mail
  headers. It replaces the given file(s) with the modified one(s).
";
    exit(@_ ? 1 : 0);
}

use Getopt::Long;
our $verbose = 0;
GetOptions("verbose" => \$verbose, "help" => sub {usage}) or exit 1;

use FP::List;
use FP::IOStream qw(xfile_replace_lines xfile_chars);
use FP::Ops qw(regex_match);
use FP::Predicates qw(complement either);
use Chj::chompspace;
use Chj::TEST;

# do not warn about failures to keep owner, or backups, due to
# different user than owner
local $Chj::IO::Tempfile::warn_all_failures = 0;

# Split lines into head and body (at the first empty line)

sub lines_head_and_body($lines) {
    $lines->take_while_and_rest(complement regex_match qr/^\n\z/s)
}

# Get headers of given name; this ad-hoc mail "parser" unsafely assumes
# that the headers we're interested in consist of one line only

sub head_get ($head, $name) {
    $head->filter(regex_match qr/^\Q$name:/i)
}

# Get one of the headers

sub head_perhaps_get_one ($head, $name) {

    # XX: what if there are multiple?
    head_get($head, $name)->perhaps_one
}

sub head_xgetone ($head, $name) {
    my ($header) = head_perhaps_get_one($head, $name)
        or die "missing header '$name'";
    $header
}

# Extract the value of a header

sub header_value($header) {
    $header =~ s/^[^:]+:// or die "header line missing a key: '$header'";
    chompspace $header
}

TEST { header_value "From:  <foo\@br>\t\n" } '<foo@br>';

sub regex_from_strings {
    join("|", map { quotemeta $_ } @_)
}

my $drop_header_name_regex = regex_from_strings(
    qw(
        Return-Path
        BCC
        X-K9mail-Identity
        User-Agent
        Date
        Message-ID)
);

sub fixlines($lines) {
    my ($head, $body) = lines_head_and_body $lines;

    my $from = head_xgetone $head, "From";
    my ($fromaddr) = $from =~ m@<([^<>]+)>@s
        or die "missing from address in '$from'";
    my ($fromwhole)  = $from     =~ m@.?: *([^\n]*)@s or die "?";
    my ($fromdomain) = $fromaddr =~ m{\@(.*)}s        or die "?";
    my $messageid_uuid = do {
        if (my ($messageid) = head_perhaps_get_one($head, "Message-ID")) {
            my ($str) = header_value($messageid) =~ m{([^<>@]+)\@}s
                or die "no match in messageid '$messageid'";
            $str
        } else {
            xfile_chars("/dev/urandom")->take(16)->map (
                sub ($c) {
                    sprintf '%02x', ord $c
                }
                )->string
        }
    };
    my $bcc_values = cons $fromwhole,
        head_get($head, "BCC")->map(\&header_value);

    (
        cons "Return-Path: <$fromaddr>\n",
        cons "BCC: " . $bcc_values->strings_join(", ") . "\n",
        $head->filter_with_tail(
            complement(regex_match("(?^i:^$drop_header_name_regex:)")),
            cons "Message-ID: <$messageid_uuid\@$fromdomain>\n",
            $body
        )
    )
}

sub string2lines($str) {
    list map {"$_\n"} split /\n/, $str
}

TEST {
    fixlines(
        string2lines 'return-path: Hello
from: <foo@bar.com>
To: Heiri Hunten <heiri.hunten@example.com>
Bcc: some@where.com
message-id: 1235@meh
user-agent: tester

Hi There!

All good?
'
    )->strings_join("")
}
'Return-Path: <foo@bar.com>
BCC: <foo@bar.com>, some@where.com
from: <foo@bar.com>
To: Heiri Hunten <heiri.hunten@example.com>
Message-ID: <1235@bar.com>

Hi There!

All good?
';

sub sendprepare($path) {
    xfile_replace_lines $path, \&fixlines;
}

$ENV{DEBUG}
    ? do {
    require FP::Repl::Trap;
    FP::Repl::repl();
    }
    : do {
    perhaps_run_tests __PACKAGE__ or do { sendprepare $_ for @ARGV };
    };