#!/v/openpkg/sw/bin/perl
##
##  petidomo.cgi -- Send a mail to Petidomo
##  Copyright (c) 1999-2001 Ralf S. Engelschall, All Rights Reserved. 
##

#   switch to unbuffered I/O
$|++;

#   generate a webpage
sub send_page {
    my ($text) = @_;

    $O = '';
    $O .= "Content-type: text/html\n" .
          "Connection: close\n" .
          "\n";
    open(FP, "<petidomo.cgi.page.head.html");
    $O .= $_ while (<FP>); 
    close(FP);
    $O .= $text;
    open(FP, "<petidomo.cgi.page.foot.html");
    $O .= $_ while (<FP>); 
    close(FP);
    print $O;
}

#   check taken from OSSP lmtp2nntp_main.c revision 1.80
sub check_rfc0821domain($)
{
    my ($check) = @_;

    # BNF grammar for <domain> according to RFC0821:
    # <snum>        ::= one, two, or three digits representing a decimal integer value in the range 0 through 255
    # <a>           ::= any one of the 52 alphabetic characters A through Z in upper case and a through z in lower case
    # <d>           ::= any one of the ten digits 0 through 9
    # <let-dig-hyp> ::= <a> | <d> | "-"
    # <let-dig>     ::= <a> | <d>
    # <ldh-str>     ::= <let-dig-hyp> | <let-dig-hyp> <ldh-str>
    # <dotnum>      ::= <snum> "." <snum> "." <snum> "." <snum>
    # <number>      ::= <d> | <d> <number>
    # <name>        ::= <a> <ldh-str> <let-dig>
    # <element>     ::= <name> | "#" <number> | "[" <dotnum> "]"
    # <domain>      ::= <element> | <element> "." <domain>
    #
    # corresponding Perl regular expression ($domain)
    #
    my $snum        = "(?:[0-9]|[0-9]{2}|[0-1][0-9]{2}|2[0-4][0-9]|25[0-5])";
    my $d           = "[0-9]";
    my $a           = "[A-Za-z]";
    my $let_dig_hyp = "(?:$a|$d|-)";
    my $let_dig     = "(?:$a|$d)";
    my $ldh_str     = "${let_dig_hyp}+";
    my $dotnum      = "$snum\\.$snum\\.$snum\\.$snum";
    my $number      = "$d+";
    my $name        = "$a$ldh_str$let_dig";
    my $element     = "(?:$name|#$number|\\[$dotnum\\])";
    my $domain      = "(?:$element\.)*$element";

    return $check =~ m/^$domain$/;
}

#   check taken from OSSP lmtp2nntp_main.c revision 1.80
sub check_rfc1035domain($)
{
    my ($check) = @_;

    # BNF grammar for <domain> according to RFC1035:
    # <letter>      ::= any one of the 52 alphabetic characters A through Z in upper case and a through z in lower case
    # <digit>       ::= any one of the ten digits 0 through 9
    # <let-dig>     ::= <letter> | <digit>
    # <let-dig-hyp> ::= <let-dig> | "-"
    # <ldh-str>     ::= <let-dig-hyp> | <let-dig-hyp> <ldh-str>
    # <label>       ::= <letter> [ [ <ldh-str> ] <let-dig> ]
    # <subdomain>   ::= <label> | <subdomain> "." <label>
    # <domain>      ::= <subdomain> | " "
    #
    # corresponding Perl regular expression ($domain)
    #
    my $letter      = "[A-Za-z]";
    my $digit       = "[0-9]";
    my $let_dig     = "(?:$letter|$digit)";
    my $let_dig_hyp = "(?:$let_dig|-)";
    my $ldh_str     = "${let_dig_hyp}+";
    my $label       = "(?:$letter(?:(?:$ldh_str)?$let_dig)?)";
    my $subdomain   = "(?:$label\.)*$label";
    my $domain      = "(?:$subdomain| )";

    return $check =~ m/^$domain$/;
}

#   let us catch runtime errors...
eval {

#   PATH_INFO
$path_info = $ENV{'PATH_INFO'};

#   QUERY_STRING
$query_string = $ENV{'QUERY_STRING'};
if ($ENV{'REQUEST_METHOD'} eq 'POST') {
    $query_string = '';
    while (<STDIN>) { $query_string .= $_; }
}
%qs = ();
@pairs = split(/&/, $query_string);
foreach $pair (@pairs) {
    my ($name, $value) = split(/=/, $pair);
    $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack('C', hex($1))/eg;
    if ($qs{$name} ne '') {
        $qs{$name} .= ",$value";
    }
    else {
        $qs{$name} = $value;
    }
    #   prevent cross side scripting (XSS) attacks
    $qs{$name} =~ s/&/&amp;/sg;
    $qs{$name} =~ s/</&lt;/sg;
    $qs{$name} =~ s/>/&gt;/sg;
    $qs{$name} =~ s/\(/&#40;/sg;
    $qs{$name} =~ s/\)/&#41;/sg;
    $qs{$name} =~ s/#/&#35;/sg;
}

#   check for parameter consistency
die "You supplied no Email address." 
    if ($qs{email} eq '');
die "Hmmm... <tt>you\@example.com</tt> is certainly not correct." 
    if ($qs{email} eq 'you@example.com');
die "Hmmm... more than a single \@ in <tt>$qs{email}</tt> is confusing me."
    if ($qs{email} =~ m|@.*@|);
die "Hmmm... no \@ in <tt>$qs{email}</tt> looks incomplete."
    unless ($qs{email} =~ m|^(.*)@(.*)$|);
($user, $domain) = ($1, $2);
die "Hmmm... user part in <tt>$qs{email}</tt> is empty."
    if($user eq '');
die "Hmmm... domain part in <tt>$qs{email}</tt> is empty."
    if($domain eq '');
die "Hmmm... <tt>$qs{email}</tt> doesn't seem to list a valid RFC822 user."
    if ($user !~ m|^[a-zA-Z0-9_=%,.~+-]+$|);
die "Hmmm... <tt>$qs{email}</tt> doesn't seem to list a valid RFC821 or RFC1035 domain."
    unless (&check_rfc0821domain($domain) or &check_rfc1035domain($domain));
die "At least one list has to be selected."
    if ($qs{list} eq '');
die "At least one action has to be selected."
    if ($qs{action} eq '');
die "Bogus action!"
    if ($qs{action} ne 'subscribe' and $qs{action} ne 'unsubscribe');

#   generate mail
$mail = '';
$mail .= "From: $qs{email}\n";
$mail .= "Reply-To: $qs{email}\n";
$mail .= "Subject: Subscription to OpenPKG mailing list(s)\n";
$mail .= "To: petidomo\@openpkg.org\n";
$mail .= "\n";
foreach $list (split(/,/, $qs{list})) { 
    die "Bogus listname!"
        if ($list ne 'openpkg-announce' and 
            $list ne 'openpkg-cvs' and
            $list ne 'openpkg-dev' and
            $list ne 'openpkg-users');
    $mail .= "$qs{action} $list $qs{email}\n";
}

#  send out mail
open(MAIL, "|/v/openpkg/sw/sbin/sendmail -oi petidomo\@openpkg.org") || die;
print MAIL $mail;
close(MAIL);

#  generate result page
&send_page(
    "Ok, the ingredients of the form were successfully parsed " .
    "and forwarded to Petidomo via Email in the following format:" .
    "<p>" .
    "<table cellpadding=5 bgcolor=\"#e5e0d5\"><tr><td>" .
    "<pre>$mail</pre>\n" .
    "</td></tr></table>" .
    "<p>" .
    "Expect a reply in your $qs{email} Email folder the next minutes.\n"
);

#   die gracefully
exit(0);

#   ...the runtime error handler:
};
if ($@) {
    my $text = $@;
    $text =~ s|^Died|Internal problem |;
    $text =~ s|\s+at /.*$||s;
    &send_page(
        "A fatal error occured while processing the ingredients of your " .
        "Petidomo request.  Please check the error message below, go back to " .
        "the form and fix the problem." .
        "<p>\n" .
        "<font color=\"#cc3333\"><b>$text</b></font>\n"
    );
}