path: root/tpnotify

#!/usr/bin/perl
# Copyright (C) 2016 Sergey Poznyakoff <gray@gnu.org>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

use strict;
use Getopt::Long qw(:config gnu_getopt no_ignore_case);
use Pod::Usage;
use Pod::Man;
use LWP::UserAgent;
use URI;
use Unix::Sysexits;
use File::Basename;
use File::Temp qw(tempdir);
use File::Path qw(remove_tree);
use IPC::Open2;
use Mail::Send;
use Mail::Message;
use Sys::Hostname;;
use Data::Dumper;
use POSIX qw(strftime);

my $progname = basename($0);
my $progdescr = "Notifies translationproject.org about new POT file";
our $VERSION = "1.0";

my $keep;          # Keep temporary directory on errors
my $signature = "$ENV{HOME}/.signature"; # Signature file
my $verbose;       # Verbose mode
my $dry_run;       # Dry-run mode
my %mailer_args;   # Mailer arguments
my $sender;        # Sender email
my $fullname;      # Sender real name
my $localdomain;   # Local domain name
my $recipient;     # Override recipient address
my @add_headers;   # Additional headers
my $refile_method; # Refiling method

my $template = <<'EOT';
To: <coordinator@translationproject.org>
Subject: $package_base.pot

Hello,

The new $release_type version of $package_name is available at:

    $url

$signature
EOT
    ;

my $url;        # Tarball URL
my $wd;         # Temporary working directory
my $filename;   # Archive file name
my $topdir;     # Toplevel directory from the archive
my %files;      # Extracted files.  Key - name under $topdir, value - pathname
		# within $wd
my $package_name;    # Package name;
my $package_tarname; # Package archive name
my $package_version; # Package version number  
my $package_base;    # Package base name
my $release_type;    # Package type (alpha or stable)

sub err {
    my $msg = shift;
    local %_ = @_;

    print STDERR "$progname: ";
    print STDERR "$_{prefix}: " if exists $_{prefix} && defined $_{prefix};
    print STDERR "$msg\n";
}

sub abend {
    my $code = shift;
    &err;
    if ($keep && $code ne EX_USAGE && $code ne EX_CONFIG) {
	err("examine $wd for details");
    }
    exit($code);
}

sub info {
    print "$progname: ";
    print @_;
    print "\n";
}

sub download {
    my ($source) = @_;
    my $url = new URI($source);
    
    $filename = basename($url->path);
    info("downloading $source to $wd/$filename") if $verbose;

    my $scheme = $url->scheme;
    eval {
	require "LWP/Protocol/$scheme.pm";
    };
    if ($@) {
	$@ =~ s/\s+at [^\s]+ line \d+\.$//;
	abend(EX_OSERR, "$@");
    }
    my $ua = LWP::UserAgent->new();
    $ua->agent("tpnotify/$VERSION");
    my $response = $ua->get($url->as_string, ':content_file' => $filename);
    unless ($response->is_success) {
	abend(EX_UNAVAILABLE,
	      "downloading $source failed: " . $response->status_line);
    }
    info("scanning $filename") if $verbose;
    open(my $fd, '-|', "tar tf $filename")
	or abend(EX_NOINPUT, "can't open $filename: $!");
    while (<$fd>) {
	chomp;
	unless (m#^(?<dir>.+?)/(?<file>.*)$#) {
	    abend(EX_DATAERR, "$filename content suspicious: member $_");
	}
	if (defined($topdir)) {
	    unless ($+{dir} eq $topdir) {
		abend(EX_DATAERR,
		      "$filename content suspicious: $+{dir} does not match $topdir");
	    }
	} else {
	    $topdir = $+{dir};
	}
	my $f = $+{file};
	if ($f eq 'configure.ac' || $f =~ m#po/.*\.pot#) {
	    $files{$f} = $_;
	}
    }
    close $fd;
    info("top level directory: $topdir") if $verbose;

    # Verify available files
    unless (exists($files{'configure.ac'})) {
	abend(EX_DATAERR, "no configure.ac in $filename");
    }
    unless (keys(%files) > 1) {
	abend(EX_DATAERR, "no potfile in $filename");
    }

    my $filelist = join(' ', values(%files));
    info("extracting from $filename") if $verbose;
    system("tar xf $filename $filelist");
    check_command_status("tar xf $filename $filelist");
    #print "tar xvf $filename " . ;
    #print "\n";
}

sub check_command_status {
    my $cmd = shift;
    my $status = shift || $?;

    if ($status == -1) {
	abend(EX_OSERR, "failed to run $cmd");
    } elsif ($status & 127) {
	abend(EX_UNAVAILABLE, "$cmd exited on signal " . ($status & 127));
    } elsif (my $e = ($status >> 8)) {
	abend(EX_UNAVAILABLE, "$cmd exited with status $e");
    }
}

sub verify_potfile {
    # FIXME
}

sub verify {
    my ($in, $out);
    my $pid = open2($out, $in, "m4 -P - $files{'configure.ac'}")
	or abend(EX_NOINPUT, "can't open $files{'configure.ac'}: $!");
    print $in <<'EOT';
m4_divert(-1)
m4_changequote([,])
m4_define([AC_INIT],[m4_divert(0)$1
$2[]m4_divert(-1)])
EOT
    close $in;
    waitpid($pid, 0);
    check_command_status("m4");
    chomp(my @lines = <$out>);
    abend(EX_DATAERR, "can't parse $files{'configure.ac'}")
	unless $#lines == 1;
    ($package_name, $package_version) = @lines;
    $package_tarname = $package_name;
    $package_tarname =~ s/GNU\s+//;
    $package_tarname = lc $package_tarname; # FIXME: this is not always right,
                                            # perhaps
    info("package $package_name, tarname $package_tarname, version $package_version") if $verbose;
    $package_base = "$package_tarname-$package_version";

    unless (defined($release_type)) {
	if ($package_version =~ m/\d+\.\d+\.(\d+)/ && int($1) >= 90) {
	    $release_type = 'alpha';
	} else {
	    $release_type = 'stable';
	}
    }

    if (substr($filename, 0, length($package_base)) ne $package_base) {
	abend(EX_DATAERR,
	      "filename $filename does not begin with $package_base");
    }
    if ($package_base ne $topdir) {
	abend(EX_DATAERR,
	      "toplevel directory $topdir does not begin with $package_base");
    }
    my $potfile = "po/$package_tarname.pot";
    unless ($files{$potfile}) {
	abend(EX_DATAERR, "potfile $potfile not found in archive");
    }
    verify_potfile;
}

sub get_special_var {
    my ($var) = @_;
    if ($var eq 'signature') {
	if (defined($signature)) {
	    if (open(my $fd, '<', $signature)) {
		local $/;
		my $sig = <$fd>;
		close($fd);
		return $sig;
	    } else {
		err("can't open signature file $signature: $!",
		    prefix => 'warning');
	    }
	}
    } elsif ($var eq 'username') {
	return $fullname;
    }
    return undef;
}

sub expand_template {
    join("\n", map {
		 s/\$(signature|username)/get_special_var($1)/gex;
		 s/(\$[a-zA-Z_][a-zA-Z0-9_]+)/eval "$1"/gex;
		 $_
	       } split(/\n/, $template)) . "\n";
}

sub read_mh_path {
    if (open(my $fd, '<', "$ENV{HOME}/.mh_profile")) {
	my $prev;
	while (<$fd>) {
	    chomp;
	    if (s/^\s+//) {
		$prev .= ' ' . $_;
	    } else {
		last if $prev =~ /^Path:/;
		$prev = $_;
	    }
	}
	close $fd;
	return $prev if $prev =~ s/^Path:\s+//;
    }
    return "$ENV{HOME}/Mail";
}

sub notify {
    my $msg = Mail::Message->read(expand_template);
    $msg->head()->add('From', "\"$fullname\" <$sender>") unless $msg->get('From');
    foreach my $hdr (@add_headers) {
	$msg->head()->add($hdr);
    }
    $msg->head()->add("X-Mailer: $progname $VERSION");
    
    if ($verbose) {
	info("message to send");
	$msg->print();
	print "\n";
	info("end of message");
    }

    if ($dry_run) {
	info("NOT sending");
	return;
    }

    info("sending message") if $verbose;

    if (my $folder = $msg->get('Fcc')) {
	$msg->head()->delete('Fcc');
	refile($msg, $folder);
    }
    $msg->send(%mailer_args);

    my $to = $recipient || $msg->get('To');
#    info("Location of $package_base.pot sent to $to");
}

sub mail_box_manager_supported {
    eval {
	require Mail::Box::Manager;
    };
    return !$@;
}

sub mail_box_manager_refile {
    my ($msg,$folder) = @_;

    my %args = (create => 1, access => 'rw');

    if ($folder =~ m#^/#) {
	$args{type} = 'mbox';
	$args{folder} = $folder;
    } elsif ($folder =~ s#mh:(?://)?(.+)#$1#) {
	$args{type} = 'mh';
	if ($folder =~ m#^/#) {
	    $args{folder} = $folder;
	} else {
	    $args{folder} = read_mh_path() . '/' . $folder;
	}
    } elsif ($folder =~ s#maildir:(?://)?(.+)#$1#) {
	$args{type} = 'maildir';
	$args{folder} = $folder;
    } else {
        abend(EX_DATAERR, "unrecognized Fcc folder: $folder");
    }

    my $mgr = Mail::Box::Manager->new();
    my $folder = $mgr->open(%args)
	or abend(EX_CANTCREAT, "can't open folder $folder");
    $folder->addMessage($msg)
	or abend(EX_CANTCREAT, "can't save message to folder $folder");
    $folder->close;
}

sub read_mh_path {
    my $file = File::Spec->catfile($ENV{HOME}, '.mh_profile');
    my $path;
    if (-f $file) {
	if (open(my $fd, '<', $file)) {
	    while (<$fd>) {
		chomp;
		if (s/Path:\s*(.+)/$1/) {
		    $path = $1;
		    last;
		}
	    }
	    close $path;
	}
    } else {
	err("can't open $file: $!", prefix => 'warning');
    }
    return $path;
}

sub movemail_supported {
    if (open(my $fd, '-|', 'movemail --version')) {
	chomp($_ = <$fd>);
	if (m{^movemail \(GNU Mailutils\) (?<maj>\d+)\.(?<min>\d+)}) {
	    return 1;
	}
    }
}

sub movemail_refile {
    my ($msg,$folder) = @_;

    my $tmpname = "message";

    open(my $fd, '>', $tmpname)
	or abend(EX_CANTCREAT, "can't create temporary file: $!");
    my $sender_address = ($msg->study('From')->addresses())[0]->address();
    print $fd "From $sender_address "
	      . strftime("%a %b %e %H:%M:%S %Y", gmtime)
	      . "\n";
    $msg->write($fd);
    close($fd);

    if ($folder =~ m{mh:(?://)?(.+)}) {
	my $dir = $1;
	if (!File::Spec->file_name_is_absolute($dir) && $dir !~ '^~') {
	    if (my $path = read_mh_path()) {
		$folder = File::Spec->catfile($path, $dir);
	    } else {
		err("no MH Path: assuming mh://$dir", prefix => 'warning');
	    }
	    $folder = 'mh://' . $folder;
	}
    }
    system("movemail $wd/$tmpname $folder");
    unlink $tmpname;
}

my %refile_tab = (
    'movemail' => { supported => \&movemail_supported,
		    refile => \&movemail_refile,
                    priority => 10 },
    'perl' =>     { supported => \&mail_box_manager_supported,
		    refile => \&mail_box_manager_refile,
	            priority => 0 }
);

sub refile {
    unless ($refile_method) {
	foreach my $meth (sort {
	    $refile_tab{$a}{priority} <=> $refile_tab{$b}{priority} }
			  keys %refile_tab) {
	    if (&{$refile_tab{$meth}{supported}}) {
		$refile_method = $meth;
		last;
	    }
	}
	unless ($refile_method) {
	    err("no method is available to refile the message");
	    return;
	}
    }
    info("using $refile_method for refiling");
    &{$refile_tab{$refile_method}{refile}}(@_);
}
	

END {
    chdir("/");
    if (!($? && $keep)) {
	remove_tree($wd, {error => \my $err});
	if (@$err) {
	    err("errors removing $wd:");
	    for my $diag (@$err) {
		my ($file, $message) = %$diag;
		if ($file eq '') {
		    err($message);
		} else {
		    err("$file: $message");
		}
	    }
	}
    }
}

sub set_mailer {
    my ($mailer, $locus) = @_;
    if ($mailer =~ /sendmail:(.*)/) {
	$mailer_args{via} = 'sendmail';
	$mailer_args{executable} = $1 if $1;
    } elsif ($mailer =~ m#smtp://(?:(?<user>[^:]+)(?::(?<password>.+))?@)?(?<host>[^:]+)(?::(?<port>\d+))?#) {
	$mailer_args{via} = 'smtp';
	$mailer_args{hostname} = $+{host};
	$mailer_args{port} = $+{port} if $+{port};
	$mailer_args{username} = $+{user} if $+{user};
	$mailer_args{password} = $+{password} if $+{password};
    } else {
	err("unknown mailer spec", prefix => $locus);
	return 0;
    } 
    return 1;
}    

sub read_template_file {
    my ($file, $locus) = @_;
    if (open(my $fd, '<', $file)) {
	local $/;
	$template = <$fd>;
	close($fd);
	return 1;
    } else {
	err("can't open template file $file: $!", prefix => $locus);
	return 0;
    }
}
    
my %kw = (
    keep => \$keep,
    'template-file' => \&read_template_file,
    template => \$template,
    'signature-file' => \$signature,
    mailer => \&set_mailer,
    from => \$sender,
    sender => \$sender,
    fullname => \$fullname,
    domain => \$localdomain,
    to => \$recipient,
    add => \@add_headers,
    'add-header' => \@add_headers,
    'refile-method' => \$refile_method
);

sub read_config {
    my $config_file = shift;
    open(FILE, "<", $config_file)
	or abend(EX_NOINPUT, "cannot open $config_file: $!");
    my $line = 0;
    my $err;
    my $key;
    my $val;
    my $heredoc;
    my $heredoc_line;
    while (<FILE>) {
	++$line;

	if ($heredoc) {
	    if (/^$heredoc\s*$/) {
		$heredoc = undef;
	    } else {
		$val .= $_;
		next;
	    }
	} else {
	    chomp;
	    s/^\s+//;
	    s/\s+$//;
	    s/#.*//;
	    next if ($_ eq "");
	
	    if (/^(.*?)\s*=\s*(.*)/) {
		$key = $1;
		$val = $2;
		
		if ($val =~ /<<(\w+)\s*$/) {
		    $heredoc = $1;
		    $heredoc_line = $line;
		    $val = '';
		    next;
		}
	    } else {
		err("$config_file:$line: syntax error");
		++$err;
	    }
	}

	if (exists($kw{$key})) {
	    my $ref = $kw{$key};
	    if (ref($ref) eq 'CODE') {
		unless (&{$ref}($val, "$config_file:$line")) {
		    ++$err;
		}
	    } elsif (ref($ref) eq 'ARRAY') {
		push @{$ref}, $val;
	    } else {
		$$ref = $val;
	    }
	} else {
	    err("$config_file:$line: unrecognized keyword: '$key'");
	    ++$err;
	}
    }
    close FILE;

    abend(EX_CONFIG, "unfinished heredoc, started at line $heredoc_line")
	if defined $heredoc;
    abend(EX_CONFIG, "errors in config file") if $err;
}

#
my $debug;
my $config_file = "$ENV{HOME}/.tpnotify" if -e "$ENV{HOME}/.tpnotify";

Getopt::Long::Configure(qw(gnu_getopt no_ignore_case pass_through));
GetOptions("help" => sub {
	      pod2usage(-exitstatus => EX_OK, -verbose => 2);
	   },
	   "h" => sub {
	      pod2usage(-message => "$progname: $progdescr",
			-exitstatus => EX_OK);
	   },
	   "usage" => sub {
	      pod2usage(-exitstatus => EX_OK, -verbose => 0);
	   },
	   "config|c=s" => \$config_file,
	   "no-config|N" => sub { $config_file = undef } 
    );

read_config($config_file) if defined $config_file;

Getopt::Long::Configure(qw(gnu_getopt no_ignore_case no_pass_through));

GetOptions("keep|k" => \$keep,
	   "alpha|A" => sub { $release_type = 'alpha' },
	   "stable|S" => sub { $release_type = 'stable' },
	   "template|t=s" => sub {
	       exit(EX_NOINPUT) unless read_template_file($_[1])
	   },
	   "signature|s=s" => \$signature,
	   "no-signature" => sub { $signature = undef },
	   "verbose|v+" => \$verbose,
	   "dry-run|n" => \$dry_run,
	   "debug|d+" => \$debug,
	   "mailer|m=s" => sub {
	       exit(EX_USAGE) unless set_mailer($_[1])
	   },
	   "from|f=s" => \$sender,
	   "fullname|F=s" => \$fullname,
	   "domain|D=s" => \$localdomain,
	   "to=s" => \$recipient,
	   "add|a=s@" => \@add_headers,
	   "refile-method=s" => \$refile_method
) or exit(EX_USAGE);

++$verbose if $dry_run;
if ($debug && exists($mailer_args{via})) {
    if ($mailer_args{via} eq 'sendmail') {
	$mailer_args{sendmail_options} = []
	    unless exists $mailer_args{sendmail_options};
	push @{$mailer_args{sendmail_options}},
	      '-O', 'LogLevel=99', '-d10.100', '-d13.90', '-d11.100';
    } elsif ($mailer_args{via} eq 'smtp') {
	$mailer_args{smtp_debug} = 1;
    }
}

if ($sender && exists($mailer_args{via})) {
    if ($mailer_args{via} eq 'sendmail') {
	$mailer_args{sendmail_options} = []
	    unless exists $mailer_args{sendmail_options};
	push @{$mailer_args{sendmail_options}}, '-f', $sender;
    } elsif ($mailer_args{via} eq 'smtp') {
	$mailer_args{from} = $sender;
    }
}

my ($name,undef,undef,undef,undef,$comment,$gecos) = getpwuid($<);
$fullname = $gecos || $comment || $name unless defined $fullname;
$sender = $name . '@' . ($localdomain || hostname()) unless defined $sender;

if ($recipient) {
    $mailer_args{to} = $recipient;
}

#print Dumper([\%mailer_args]);

$url = shift;
abend(EX_USAGE, "not enough arguments") unless defined $url;
abend(EX_USAGE, "too many arguments") unless $#ARGV == -1;
if ($refile_method) {
    abend(EX_USAGE, "unknown refiling method")
	unless exists($refile_tab{$refile_method});
    abend(EX_USAGE, "refiling method not supported")
	unless (&{$refile_tab{$refile_method}{supported}});
}

$wd = tempdir()
      or abend(EX_CANTCREAT, "can't create temporary directory: $!");
chdir($wd) or abend(EX_OSERR, "can't change to temporary directory $wd: $!");

download($url);
verify;
notify;

__END__

=head1 NAME

tpnotify - Notifies translationproject.org about new POT file

=head1 SYNOPSIS

B<tpnotify>
[B<-ANSdnkv>]
[B<-D> I<DOMAIN>]
[B<-F> I<NAME>]
[B<-a> I<HDR>B<:>I<VALUE>
[B<-c> I<FILE>]
[B<-f> I<FROM>]
[B<-m> I<SPEC>]
[B<-s> I<FILE>]
[B<-t> I<FILE>]
[B<--add=>I<HDR>:I<VAL>]    
[B<--alpha>]
[B<--config=>I<FILE>]
[B<--debug>]
[B<--domain=>I<DOMAIN>]
[B<--dry-run>]
[B<--from=>I<EMAIL>]
[B<--fullname=>I<NAME>]
[B<--keep>]
[B<--mailer=>I<SPEC>]
[B<--no-config>]
[B<--no-signature>]
[B<--refile-method=>B<perl> | B<mailutils>]    
[B<--signature=>I<FILE>]
[B<--stable>]
[B<--template=>I<FILE>]
[B<--to=>I<EMAIL>]
[B<--verbose>]
I<URL>
    
B<tpnotify>
[B<-h>]
[B<--help>]
[B<--usage>]    

=head1 DESCRIPTION

Notifies the coordinator of the I<Translation Project> about new
POT file available at I<URL>.  The URL must point to a tarball of
a package registered at TP (I<http://translationproject.org/domain/>).    
The tool works as follows:
    
First of all, the indicated I<URL> is downloaded to a temporary location
on disk.  The contents of the retrieved tarball is inspected.  It must
contain the file F<configure.ac> in the project toplevel directory and
one or more files with the B<.pot> suffix in the F<po> subdirectory.

These files are extracted.  The F<configure.ac> is parsed in order to
determine the package name and version (from the B<AC_INIT> statement).
The canonical package name is formed by concatenating the package name
(with the eventual B<GNU> prefix stripped), a dash, and the version
number.  The name of the POT file is constructed by appending the
B<.pot> suffix to the base name,  This file is looked up in the B<po>
subdirectory.

When this initial stage is through, the message template is expanded.
See the B<TEMPLATE> section below, for a detailed discussion of this
stage.  The resulting email message is then sent.  Unless the B<--to>
option is given, the recipients are obtained from the headers B<To:>,
B<Cc:>, and B<Bcc:> of the formatted message.  The B<--to> option supplies
the recipient email to be used instead of those.

The B<Fcc:> header can be used to save the copy of the message being sent
in a mailbox.  If its value is an absolute or relative pathname, it is assumed
to be a mailbox in traditional B<UNIX> format (relative pathnames are
expanded relative to the user home directory).  Otherwise, it is a B<folder
url>:

=over 8    
    
=item B<mbox:>[B<//>]I<PATHNAME>

UNIX mailbox located at I<PATHNAME> (relative or absolute).

=item B<mh:>[B<//>]I<PATHNAME>

MH mailbox at I<PATHNAME>.  Relative pathnames are resolved by prepending
the value of the B<Path> header from the F<~/.mh_profile> file.  If not
defined, the B<~/Mail> directory is assumed.

=item B<maildir:>[B<//>]I<PATHNAME>

Maildir folder at I<PATHNAME>.  Relative pathnames are relative to the
current user's home directory.

=back

Two methods can be used to support B<Fcc> refiling: the B<perl> method, which
uses the B<Mail::Box::Manager> Perl package, and the B<mailutils> method,
which uses GNU mailutils.  By default, B<tpnotify> attempts to use B<perl>,
and falls back to B<mailutils> if that's not possible.  If the latter is not
available as well, it issues an error message and terminates.  The user can
select the refiling method using the B<--refile-method> option.  See the
B<BUGS> section for details.    

Additional configuration is supplied in configuration file and command line.
The latter overrides the former.  See the section B<CONFIGURATION> for a
detailed discussion of the configuration file format.    
    
The B<-v> (B<--verbose>) command line option instructs the tool to verbosely
list each step being executed.  Additionally, the B<-d> (B<--debug>) option
enables a detailed printout of debugging information describing the mail
sending process.

The B<-n> (B<--dry-run>) option causes the program to verbosely print what
is being done (as ig given the B<--verbose> option), but not actually send
the constructed message.    

=head1 CONFIGURATION

The default configration file is named B<.tpnotify> and is located in the
current user home directory.  I's OK if it does not exist.  In this case
the tool will use the built-in defaults.  Two command line options are
provided to alter that behavior.  The B<-c I<FILE>> (B<--config=>I<FILE>)
option causes the program to read configuration file from I<FILE>.  It
is an error if that file does not exist or is unreadable.  The B<--no-config>
option instructs B<tpnotify> to ignore the configuration file.

When reading the configuration file, empty lines and lines starting with
a hash sign (B<#>) are ignored.  Remaining lines must contain valid
configuration statements,

A statement consists of a keyword, followed by an equals sign and a value.
Arbitrary amount of white space are allowed at the beginning and end of
line, as well as around the equals sign.  Multiline values can be entered
using the familiar I<here-document> syntax.  A here-document is
introduced by the B<<<> marker followed by arbitrary word.  The lines following
that construct are collected and concatenated until a line is found that
contains only t