From 7c0689660adad268a0a0ffc80d3916df48609632 Mon Sep 17 00:00:00 2001 From: Sergey Poznyakoff Date: Thu, 11 Aug 2016 18:07:19 +0300 Subject: Initial commit --- tpnotify | 1003 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1003 insertions(+) create mode 100755 tpnotify (limited to 'tpnotify') diff --git a/tpnotify b/tpnotify new file mode 100755 index 0000000..3916d61 --- /dev/null +++ b/tpnotify @@ -0,0 +1,1003 @@ +#!/usr/bin/perl +# Copyright (C) 2016 Sergey Poznyakoff +# +# 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 . + +use strict; +use Getopt::Long qw(:config gnu_getopt no_ignore_case); +use Pod::Usage; +use Pod::Man; +use WWW::Curl::Easy; +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; + +my $progname = basename($0); +my $progdescr = "FIXME"; +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 $template = <<'EOT'; +To: +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 ($url) = @_; + my $curl = WWW::Curl::Easy->new; + $curl->setopt(CURLOPT_HEADER,0); + $curl->setopt(CURLOPT_URL, $url); + $filename = basename($url); + info("downloading $filename from $url") if $verbose; + open(my $fd, '>', $filename) + or abend(EX_CANTCREAT, "can't open $wd/$filename for writing: $!"); + $curl->setopt(CURLOPT_WRITEDATA, $fd); + my $retcode = $curl->perform; + if ($retcode) { + abend(EX_UNAVAILABLE, + "failed to download: ".$curl->strerror($retcode)." ".$curl->errbuf); + } else { + my $code = $curl->getinfo(CURLINFO_HTTP_CODE); + if ($code != 200) { + print STDERR "error downloading: HTTP code $code\n"; +#FIXME system("cat >&2 $filename"); + die "aborted"; + } + } + close($fd); + info("scanning $filename") if $verbose; + open($fd, '-|', "tar tf $filename") + or abend(EX_NOINPUT, "can't open $filename: $!"); + while (<$fd>) { + chomp; + unless (m#^(?.+?)/(?.*)$#) { + 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+//; + 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)); +} + +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'); + + 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"); + } + + use Mail::Box::Manager; + 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; + } + + $msg->send(%mailer_args); + + my $to = $recipient || $msg->get('To'); +# info("Location of $package_base.pot sent to $to"); +} + +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://(?:(?[^:]+)(?::(?.+))?@)?(?[^:]+)(?::(?\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 +); + +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 () { + ++$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 +) 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; + +$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 +[B<-ANSdnkv>] +[B<-D> I] +[B<-F> I] +[B<-a> IB<:>I +[B<-c> I] +[B<-f> I] +[B<-m> I] +[B<-s> I] +[B<-t> I] +[B<--add=>I:I] +[B<--alpha>] +[B<--config=>I] +[B<--debug>] +[B<--domain=>I] +[B<--dry-run>] +[B<--from=>I] +[B<--fullname=>I] +[B<--keep>] +[B<--mailer=>I] +[B<--no-config>] +[B<--no-signature>] +[B<--signature=>I] +[B<--stable>] +[B<--template=>I] +[B<--to=>I] +[B<--verbose>] +I + +B +[B<-h>] +[B<--help>] +[B<--usage>] + +=head1 DESCRIPTION + +Notifies the coordinator of the I about new +POT file available at I. The URL must point to a tarball of +a package registered at TP (I). +The tool works as follows: + +First of all, the indicated I is downloaded to a temporary location +on disk. The contents of the retrieved tarball is inspected. It must +contain the file F in the project toplevel directory and +one or more files with the B<.pot> suffix in the F subdirectory. + +These files are extracted. The F is parsed in order to +determine the package name and version (from the B statement). +The canonical package name is formed by concatenating the package name +(with the eventual B 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 +subdirectory. + +When this initial stage is through, the message template is expanded. +See the B