#! /usr/bin/perl

# Updated August, 2001 Tollef Fog Heen <tollef@add.no>
# Version 1.7
# Support for GPG instead of PGP, while maintaining compatibility with 
# old sites running PGP

# written April 1996, tale@isc.org (David C Lawrence)
# Version 1.6, 14 October 1998
#
# Changes from 1.5 to 1.6:
#  -- eliminated subprocess use (except pgp, of course)
#  -- interlock against competing signing processes
#  -- allow optional headers; see $use_or_add
#  -- added simple comments about why particular headers are signed
#  -- made error messages a tad more helpful for situations when it is hard
#     to know what message was trying to be signed (such as via an "at" job)
#  -- set $action, $group, $moderated to "" to prevent unusued variable
#     warnings in the event a Control header can't be parsed
#  -- moved assignment of $pgpend out of loop.
# Changes from 1.4 to 1.5
#  -- need to require Text::Tabs to get 'expand' for tabs in checkgroups
# Changes from 1.3 to 1.4:
#  -- added checkgroups checking
#  -- added group name in several error messages (for help w/batch processing)
#  -- disabled moderator address checking
#  -- adjusted newsgroups line (ie, tabbing fixed) now correctly substituted
#     into control message.
# Changes from 1.2.3 to 1.3:
#  -- skip minor pgp signature headers like "charset:" after "version:" header
#     and until the empty line that starts the base64 signature block

# CONFIGURATION

require "/etc/news/signcontrol.conf";

## END CONFIGURATION

use POSIX qw(setlocale strftime LC_TIME dup2);
use Text::Tabs;                 # to get 'expand' for tabs in checkgroups

$0 =~ s#^.*/##;

die "Usage: $0 < message\n" if @ARGV > 0;

umask(0022);                    # flock needs a writable file, if we create it
open(LOCK, ">>$pgplock") || die "$0: open $lock: $!, exiting\n";
flock(LOCK, 2);                 # block until locked

&setgrouppat;

$die = '';

&readhead;
&readbody;

if ($die) {
  if ($group) {
    die "$0: ERROR PROCESSING ${action}group $group:\n", $die;
  } elsif ($action eq 'check') {
    die "$0: ERROR PROCESSING checkgroups:\n", $die;
  } elsif ($header{'Subject'}) {
    die "$0: ERROR PROCESSING Subject: $header{'Subject'}\n", $die;
  } else {
    die $die;
  } 
}

&signit;

close(LOCK) || warn "$0: close $lock: $!\n";
exit 0;

sub
setgrouppat

{
  my ($hierarchy, $plain_component, $no_component);
  my ($must_start_letter, $should_start_letter);
  my ($eval);

  # newsgroup name checks based on RFC 1036bis (not including encodings) rules:
  #  "component MUST contain at least one letter"
  #  "[component] MUST not contain uppercase letters"
  #  "[component] MUST begin with a letter or digit"
  #  "[component] MUST not be longer than 14 characters"
  #  "sequences 'all' and 'ctl' MUST not be used as components"
  #  "first component MUST begin with a letter"
  # and enforcing "subsequent components SHOULD begin with a letter" as MUST
  # and enforcing at least a 2nd level group (can't use to newgroup "general")
  #
  # DO NOT COPY THIS PATTERN BLINDLY TO OTHER APPLICATIONS!
  #   It has special construction based on the pattern it is finally used in.

  $plain_component = '[a-z][-+_a-z\d]{0,13}';
  $no_component = '(.*\.)?(all|ctl)(\.|$)';
  $must_start_letter = '(\.' . $plain_component . ')+';
  $should_start_letter = '(\.(?=\d*[a-z])[a-z\d]+[-+_a-z\d]{0,13})+';

  $grouppat = "(?!$no_component)($hierarchies)";
  if ($start_component_with_letter eq 'SHOULD') {
    $grouppat .= $should_start_letter;
  } elsif ($start_component_with_letter eq 'MUST') {
    $grouppat .= $must_start_letter;
  } else {
    die "$0: unknown value configured for \$start_component_with_letter\n";
  }

  foreach $hierarchy (split(/\|/, $hierarchies)) {
    die "$0: hierarchy name $hierarchy not standards-compliant\n"
      if $hierarchy !~ /^$plain_component$/o;
  }

  $eval = "\$_ = 'test'; /$grouppat/;";
  eval $eval;
  die "$0: bad regexp for matching group names:\n $@" if $@;
}

sub
readhead

{
  my($head, $label, $value);
  local($_, $/);

  $/ = "";
  $head = <STDIN>;              # get the whole news header
  $die .= "$0: continuation lines in headers not allowed\n"
    if $head =~ s/\n[ \t]+/ /g; # rejoin continued lines

  for (split(/\n/, $head)) {
    if (/^(\S+): (.*)/) {
      $label = $1;
      $value = $2;

      $die .= "$0: duplicate header $label\n" if $header{$label};

      $header{$label} = $value;
      $header{$label} =~ s/^\s+//;
      $header{$label} =~ s/\s+$//;
    } elsif (/^$/) {
      ;                           # the empty line separator(s)
    } else {
      $die .= "$0: non-header line:\n  $_\n";
    }
  }

  $header{'Message-ID'} = '<' . time . ".$$\@$id_host>";

  setlocale(LC_TIME, "C");
  $header{'Date'} = strftime("%a, %d %h %Y %T -0000", gmtime);

  for (@ignoreheaders) {
    $die .= "ignored header $_ also has forced value set\n" if $force{$_};
    $header{$_} = '';
  }

  for (@orderheaders) {
    $header{$_} = $force{$_} if defined($force{$_});
    next if /^(Lines|\Q$pgpheader\E)$/; # these are set later
    unless ($header{$_}) {
      if (defined($use_or_add{$_})) {
        $header{$_} = $use_or_add{$_} if $use_or_add{$_} ne '';
      } else {
        $die .= "$0: missing $_ header\n";
      }
    }
  }

  $action = $group = $moderated = "";
  if ($header{'Control'}) {
    if ($header{'Control'} =~ /^(new)group (\S+)( moderated)?$/o ||
        $header{'Control'} =~ /^(rm)group (\S+)()$/o ||
        $header{'Control'} =~ /^(check)groups()()$/o) {
      ($action, $group, $moderated) = ($1, $2, $3);
      $die .= "$0: group name $group is not standards-compliant\n"
        if $group !~ /^$grouppat$/ && $action eq 'new';
      $die .= "$0: no group to rmgroup on Control: line\n"
        if ! $group && $action eq 'rm';
      $header{'Subject'} = "cmsg $header{'Control'}";
      $header{'Newsgroups'} = $group unless $action eq 'check';
    } else {
      $die .= "$0: bad Control format: $header{'Control'}\n";
    }
  } else {
    $die .= "$0: can't verify message content; missing Control header\n";
  }
}

sub
readbody

{
  local($_, $/);
  local($status, $ngline, $fixline, $used, $desc, $mods);

  undef $/;
  $body = $_ = <STDIN>;
  $header{'Lines'} = $body =~ tr/\n/\n/ if $body;

  # the following tests are based on the structure of a news.announce.newgroups
  # newgroup message; even if you comment out the "first line" test, please
  # leave the newsgroups line and moderators checks
  if ($action eq 'new') {
    $status = $moderated ? 'a\smoderated' : 'an\sunmoderated';
    $die .= "$0: nonstandard first line in body for $group\n"
      if ! /^\Q$group\E\sis\s$status\snewsgroup\b/;

    my $intro = "For your newsgroups file:\n";
    $ngline =
      (/^$intro\Q$group\E[ \t]+(.+)\n(\n|\Z(?!\n))/mi)[0];
    if ($ngline) {
      $_ = $group;
      $desc = $1;
      $fixline = $_;
      $fixline .= "\t" x ((length) > 23 ? 1 : (4 - ((length) + 1) / 8));
      $used = (length) < 24 ? 24 : (length) + (8 - (length) % 8);
      $used--;
      $desc =~ s/ \(Moderated\)//i;
      $desc =~ s/\s+$//;
      $desc =~ s/\w$/$&./;
      $die .= "$0: $group description too long\n" if $used + length($desc) > 80;
      $fixline .= $desc;
      $fixline .= ' (Moderated)' if $moderated;
      $body =~ s/^$intro(.+)/$intro$fixline/mi;
    } else {
      $die .= "$0: $group newsgroup line not formatted correctly\n";
    }
    # moderator checks are disabled; some sites were trying to automatically
    # maintain aliases based on this, which is bad policy.
    if (0 && $moderated) {
      $die .= "$0: $group submission address not formatted correctly\n"
        if $body !~ /\nGroup submission address:   ?\S+@\S+\.\S+\n/m;
      $mods = "( |\n[ \t]+)\\([^)]+\\)\n\n";
      $die .= "$0: $group contact address not formatted correctly\n"
        if $body !~ /\nModerator contact address:  ?\S+@\S+\.\S+$mods/m;
    }
  }
  # rmgroups have freeform bodies

  # checkgroups have structured bodies
  if ($action eq 'check') {
    for (split(/\n/, $body)) {
      my ($group, $description) = /^(\S+)\t+(.+)/;
      $die .= "$0: no group:\n  $_\n"           unless $group;
      $die .= "$0: no description:\n  $_\n"     unless $description;
      $die .= "$0: bad group name \"$group\"\n" if $group !~ /^$grouppat$/;
      $die .= "$0: tab in description\n"        if $description =~ /\t/;
      s/ \(Moderated\)$//;
      $die .= "$0: $group line too long\n"      if length(expand($_)) > 80;
    }
  }
}

sub
signit

{
  my($head, $header, $signheaders, $pgpflags, $pgpbegin, $pgpend);
  local(*FH);

  $signheaders = join(",", @signheaders);

  $head = "X-Signed-Headers: $signheaders\n";
  foreach $header (@signheaders) {
    $head .= "$header: $header{$header}\n";
  }

  if ($pgppassfile && -f $pgppassfile) {
    $pgppassfile =~ s%^(\s)%./$1%;
    if (open(PGPPASS, "< $pgppassfile\0")) {
      $ENV{'PGPPASS'} = <PGPPASS>;
      close(PGPPASS);
    }
    chomp $ENV{'PGPPASS'} if $ENV{'PGPPASS'};
    # if PGPPASS is not now set and non-null, it will be prompted for by pgp
  }

  $| = 1;
  $^F = 10; # Safe value
  pipe(PGPPASS_R,PGPPASS_W);
  pipe(PGPR,PGPW);
  pipe(PGP_BODYR,PGP_BODYW);
  $pid = fork();
  if ($pid == 0) {
       # child
       close(PGPR);
       close(PGPPASS_W);
       close(PGP_BODY_W);

       dup2(fileno PGPW, fileno STDOUT) || die "Can't dup2";
       dup2(fileno PGP_BODY_R, fileno STDIN) || die "Can't dup2";

       @pass_fd = ();
       if ($ENV{'PGPPASS'}) {
	    @pass_fd = ("--no-tty", "--passphrase-fd", fileno(PGPPASS_R));
       }

       exec $pgp, @pass_fd, qw( --output - --textmode --armor --local-user), $pgpsigner, qw( --set-filename stdin --escape-from --clearsign -);
  }
  close PGPW;
  close PGP_BODY_R;
  print PGP_BODY_W $head;
  print PGP_BODY_W "\n";
  print PGP_BODY_W $body;
  close PGP_BODY_W;

  print PGPPASS_W "$ENV{PGPPASS}\n" || die "Can't write passphrase";
  close PGPPASS_W;

  # whack any passphrase out of our environment.  don't let this kid 
  # you, it does not stop snooping.
  delete $ENV{'PGPPASS'};
  $pgpbegin = "-----BEGIN PGP SIGNATURE-----";
  $/ = "$pgpbegin\n";
  $_ = <PGPR>;                         # read to signature, discard
  die "$0: $pgpbegin not found in $_\n" unless /\Q$pgpbegin\E$/;

  # finish getting the signature
  $/ = "\n";
  $_ = <PGPR>;
  die "$0: didn't find PGP Version line where expected: $_\n"
    unless /^Version: (.+)$/;
  $tmp = $1;
  $tmp =~ s/\(.*\)//;
  $tmp =~ s/\s*$//g;  
  $tmp =~ s/\s/\//g;
  $header{$pgpheader} = "$tmp $signheaders";
  
  do {                # skip other pgp headers like "charset:" until empty line
    $_ = <PGPR>;        # ... is charset significant to this application?
  } while ! /^$/;

  $pgpend = '-----END PGP SIGNATURE-----';
  while (<PGPR>) {
    chomp;
    last if /^\Q$pgpend\E$/;
    $header{$pgpheader} .= "\n\t$_";
  }
  $_ = <PGPR>;
  die "$0: unexpected data following $pgpend\n" unless eof(PGPR);
  close(PGPR) || warn "$0: close pipe from pgp returned status $?\n";

  for (@ignoreheaders) {
    delete $header{$_} if defined $header{$_};
  }

  $head = '';
  foreach $header (@orderheaders) {
    $head .= "$header: $header{$header}\n" if $header{$header};
    delete $header{$header};
  }

  foreach $header (keys %header) {
    die "$0: unexpected header $header left in header array\n";
  }

  print STDOUT $head;
  print STDOUT "\n";
  print STDOUT $body;
}

# Our lawyer told me to include the following.  The upshot of it is
# that you can use the software for free as much as you like.

# Copyright (c) 1996 UUNET Technologies, Inc.
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. All advertising materials mentioning features or use of this software
#    must display the following acknowledgement:
#      This product includes software developed by UUNET Technologies, Inc.
# 4. The name of UUNET Technologies ("UUNET") may not be used to endorse or
#    promote products derived from this software without specific prior
#    written permission.
#
# THIS SOFTWARE IS PROVIDED BY UUNET ``AS IS'' AND ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED.  IN NO EVENT SHALL UUNET BE LIABLE FOR ANY DIRECT,
# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
# OF THE POSSIBILITY OF SUCH DAMAGE.
