#!/usr/bin/perl -w

# Copyright (c) 2015 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 Function::Parameters qw(:strict);
#use Sub::Call::Tail;

# 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 Chj::Trapl; use Chj::repl;
use FP::List;
use FP::IOStream qw(xfile_replace_lines);
use FP::Ops qw(regex_match);
use FP::Predicates qw(complement either);
# ^ should these (also) be in FP::Combinators?

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


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


# This ad-hoc mail "parser" unsafely assumes that the headers we're
# interested in consist of one line only

fun xheader ($head, $name) {
    $head->filter (regex_match qr/^\Q$name:/)->xone
}

fun fixlines ($orig) {
    my ($head,$rest)= $orig->
      take_while_and_rest (complement regex_match qr/^\n\z/s);

    my $from= xheader $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= xheader $head, "Message-ID";
    my ($messageid_uuid)= $messageid=~ m{([^<>@]+)\@}s
      or die "no match in messageid '$messageid'";

    (cons "Return-Path: <$fromaddr>\n",
     cons "BCC: $fromwhole\n",
     $head->filter_with_tail
     (complement
      (regex_match ("^".
		    regex_from_strings (qw(Return-Path
					   BCC
					   X-K9mail-Identity
					   User-Agent
					   Date
					   Message-ID)).
		    ":")),
      cons "Message-ID: <$messageid_uuid\@$fromdomain>\n",
      $rest))
}

fun sendprepare ($path) {
    xfile_replace_lines $path, *fixlines;
}

sendprepare $_ for @ARGV;

