File Coverage

blib/lib/NNML/Connection.pm

Criterion	Covered	Total	%
statement	40	468	8.5
branch	0	158	0.0
condition	0	36	0.0
subroutine	13	54	24.0
pod	0	41	0.0
total	53	757	7.0

#                              -*- Mode: Perl -*-
# Connection.pm --
# ITIID           : $ITI$ $Header $__Header$
# Author          : Ulrich Pfeifer
# Created On      : Sat Sep 28 15:24:53 1996
# Last Modified By: Ulrich Pfeifer
# Last Modified On: Mon Mar 31 09:19:23 1997
# Language        : CPerl
# Update Count    : 331
# Status          : Unknown, Use with caution!
#
# (C) Copyright 1996, Universität Dortmund, all rights reserved.
#

package NNML::Connection;
use NNML::Active qw($ACTIVE);
use NNML::Config qw($Config);
use Text::Abbrev;
use Time::Local;
use Socket;
use strict;
use Sys::Hostname;
use IO::Select;

require NNML::Auth;

use vars qw(%ACMD %CMD %MSG %HELP);

my $HOST = hostname;
{
  no strict;
  local *stab = *NNML::Connection::;
  my ($key,$val);
  while (($key,$val) = each(%stab)) {
    next unless $key =~ /^cmd_(.*)/;
    local(*ENTRY) = $val;
    if (defined &ENTRY) {
      $CMD{$1} = \&ENTRY;
    }
  }
}

abbrev(*ACMD, keys %CMD);

sub new {
  my $type = shift;
  my $fh   = shift;
  my $msg  = shift;
  my $self = {_fh => $fh};

  my $hersockaddr = $fh->peername();
  my ($port, $iaddr) = unpack_sockaddr_in($hersockaddr);
  my $peer = gethostbyaddr($iaddr, AF_INET);
  $self->{_peer}   = $peer;
  $self->{_user}   = 'nobody';
  $self->{_passwd} = '*';
  print "Connection from $peer\n";
  bless $self, $type;
  $self->msg(200, $msg);
  $self;
}

sub close {
  my $self = shift;

  $self->{_fh}->close;
}

sub dispatch {
  my $self = shift;
  my $cmd  = shift;

  print "$cmd @_\n";
  unless (exists $ACMD{$cmd}) {
    $self->msg(500);
  } else {
    if (NNML::Auth::perm($self, $ACMD{$cmd})) {
      &{$CMD{$ACMD{$cmd}}}($self, @_);
    } else {
      $self->msg(480);
    }
  }
  return $ACMD{$cmd};
}

sub msg {
  my $self = shift;
  my $code = shift;
  my $msg  = $MSG{$code} || '';
  printf("%03d $msg\r\n", $code, @_);
  $self->{_fh}->datasend(sprintf "%03d $msg\r\n", $code, @_);
}

sub end {
  my $self = shift;
  $self->{_fh}->dataend;
}

use IO::Pipe;
use IO::File;

sub output {
  my $self = shift;

  $self->{_fh}->datasend(@_);
}


sub cmd_help {
  my $self = shift;

  $self->msg(100);
  for (sort keys %CMD) {
    $self->output(sprintf("%-15s %s\r\n", $_, $HELP{$_}||''));
  }
  $self->end;
}

sub cmd_authinfo {
  my ($self, $cmd, $arg) = @_;

  if (uc($cmd) eq  'USER') {
    $self->{_user}   = $arg;
    unless (exists $self->{_passwd} and $self->{_passwd} ne '*') {
      $self->msg(381);
      return;
    }
  } elsif (uc($cmd) eq 'PASS') {
    $self->{_passwd} = $arg;
    unless (exists $self->{_user} and $self->{_user} ne 'nobody') {
      $self->msg(382);
      return;
    }
  } else {
    $self->msg(501);
    return;
  }

  if (NNML::Auth::check($self->{_user}, $self->{_passwd})) {
    $self->msg(281)
  } else {
    $self->msg(482);
    delete $self->{_passwd};
  }
}

sub cmd_group {
  my ($self, $groupname) = @_;
  my $group = $ACTIVE->group($groupname);

  unless ($group) {
    $self->msg(411);
    return;
  }
  my $max = $group->max;
  my $min = $group->min;

  $self->{_group}   = $group;
  $self->{_article} = $min;
  $self->msg(211, $max-$min+1, $min, $max, $groupname);
}

sub cmd_mode {
  my $self = shift;
  my $mode = uc shift;

  $self->msg(280, $mode);
}

sub cmd_quit {
  my $self = shift;
  $self->msg(205);
}

sub cmd_list {
  my $self  = shift;

  if (@_) {
    my $cmd   = shift;
    my $match = shift;

    if ($cmd !~ /NEWSGROUPS/) {
      $self->msg(500);
      return;
    }
    $self->msg(215);
    for ($ACTIVE->list_match($match)) {
      $self->output($_->name, "\r\n");
    }
    $self->end;
  } else {
    $self->msg(215);
    for ($ACTIVE->groups) {
      $self->output(sprintf "%s %d %d %s\r\n",
                    $_->name, $_->max, $_->min, $_->post)
    }
    $self->end;
  }
}

sub cmd_newgroups {
  my $self = shift;
  my $ltime = to_time(@_);

  unless (defined $ltime) {
    $self->msg(501);
    return;
  }

  $self->msg(231);
  for ($ACTIVE->newgroups($ltime)) {
     $self->output($_, "\r\n");
  }
  $self->end;
}

sub cmd_newnews {
  my $self  = shift;
  my $match = shift;
  my $ltime = to_time(@_);
  my %msgid;

  $self->msg(230);
  for ($ACTIVE->list_match($match)) {
    my %new = $_->newnews($ltime);
    for (keys %new) {
      $msgid{$_} ||= $new{$_};
    }
  }
  for (sort {$msgid{$a} <=> $msgid{$b}} keys %msgid) {
    $self->output($_, "\r\n");
  }
  $self->end;
}

sub cmd_xover {
  my $self = shift;
  my $parm = shift;
  my @range = ($parm =~ m/(\d+)-(\d+)/);
  unless ($self->{_group}) {
    $self->msg(412);
    return;
  }
  my $xover = $self->{_group}->xover(@range);
  $self->msg(224);
  $self->output("$xover");
  $self->end;
}


my %FLD;

BEGIN {
  my $i;

  my @FLD = qw(ano subject from date message-id references size lines xref);

  for ($i=0;$i<@FLD;$i++) {
    $FLD{$FLD[$i]} = $i;
  }
}

sub cmd_xhdr {
  my $self = shift;
  my $fld  = shift;
  my $fno  = $FLD{lc $fld};
  my $parm = shift;
  my @range = ($parm =~ m/(\d+)-(\d+)/ || ($parm, $parm));
  unless ($self->{_group}) {
    $self->msg(412);
    return;
  }
  my $xover = $self->{_group}->xover(@range);
  $self->msg(221, $fld);
  for (split /\n/, $xover) {
    my ($ano, $val) = (split /\t/, $_)[0,$fno];
    $val = "(none)" unless $val;

    $self->output("$ano $val\r\n");
  }
  $self->end;
}

sub cmd_next {
  my $self = shift;
  unless ($self->{_group}) {
    $self->msg(412);
    return;
  }
  unless ($self->{_article}) {
    $self->msg(420);
    return;
  }
  if ($self->{_article} < $self->{_group}->max) {
    $self->{_article}++;
  } else {
    $self->msg(421);
    return;
  }
  $self->msg(223, $self->{_article},
             $self->{_group}->article_by_no($self->{_article}))
}

sub cmd_last {
  my $self = shift;
  unless ($self->{_group}) {
    $self->msg(412);
    return;
  }
  unless ($self->{_article}) {
    $self->msg(420);
    return;
  }
  if ($self->{_article} > $self->{_group}->min) {
    $self->{_article}--;
  } else {
    $self->msg(422);
    return;
  }
  $self->msg(223, $self->{_article},
             $self->{_group}->article_by_no($self->{_article}))
}

sub cmd_slave {
  my $self = shift;
  $self->{timeout} = $Config->mirror_timeout;
  $self->{slave}   = 1;
  $self->msg(202);
}

# only article number for is supported
sub cmd_stat {
  my $self = shift;
  my $ano  = shift;

  unless (defined $ano) {
    $self->msg(501);
    return;
  }
  unless ($self->{_group}) {
    $self->msg(412);
    return;
  }
  if ($ano >= $self->{_group}->min and $ano <= $self->{_group}->max) {
    $self->{_article} = $ano;
  } else {
    $self->msg(423, $self->{_group}->name);
    return;
  }
  $self->msg(223, $self->{_article},
             $self->{_group}->article_by_no($self->{_article}))
}

sub cmd_xdelete {
  my $self = shift;
  my $ano  = shift || $self->{_article};

  unless (defined $ano) {
    $self->msg(501);
    return;
  }
  unless ($self->{_group}) {
    $self->msg(412);
    return;
  }
  if ($self->{_group}->delete($ano)) {
    $self->msg(285);
  } else {
    $self->msg(485);
  }
}

sub cmd_xdeletegroup {
  my $self = shift;

  unless ($self->{_group}) {
    $self->msg(412);
    return;
  }
  if ($ACTIVE->delete_group($self->{_group}->name)) {
    $self->msg(286);
  } else {
    $self->msg(486);
  }
}

sub cmd_xmovefrom {
  my $self = shift;
  my $ano  = shift || $self->{_article};

  unless ($self->{_group}) {
    $self->msg(412);
    return;
  }

  unless ($ano) {
    $self->msg(420);
    return;
  }

  my ($head, $body) = $self->{_group}->get($ano);
  unless ($head) {
    $self->msg(423, $self->{_group}->name);
    return;
  }
  unless ($self->{_group}->delete($ano)) {
    $self->msg(285);
    return;
  }
  my ($msgid) = ($head =~ /^Message-Id:\s*(<\S+>)/m);
  $self->msg(220,$ano, $msgid);
  $self->output($head, "\n", $body);
}

sub cmd_xaccept {
  my $self = shift;

  unless ($self->{_group}) {
    $self->msg(412);
    return;
  }

  unless ($self->post) {
    $self->msg(440);
    return;
  }
  $self->msg(340);
  $self->accept_article(undef,$self->{_group}->name);
}

sub cmd_article { my $self = shift; $self->article('article', join ' ', @_)};
sub cmd_head    { my $self = shift; $self->article('head',    join ' ', @_)};
sub cmd_body    { my $self = shift; $self->article('body',    join ' ', @_)};
sub cmd_xdate   { my $self = shift; $self->article('date',    join ' ', @_)};

sub article {
  my ($self, $cmd, $parm) = @_;
  if (defined $parm and $parm =~ /^\s*<.*>\s*$/) {
    my ($head, $body) = article_msgid($parm);
    if ($head) {
      if ($cmd eq 'article') {
        $self->msg(220,0,$parm);
        $self->output($head, "\n", $body);
      } elsif ($cmd eq 'head') {
        $self->msg(225,0,$parm);
        $self->output($head);
      } else {
        $self->msg(222,0,$parm);
        $self->output($body);
      }
      $self->end;
    } else {
      $self->msg(430);
    }
  } else {
    unless ($self->{_group}) {
      $self->msg(412);
      return;
    }
    my $ano = $parm || $self->{_article};
    unless ($ano =~ /^\d+$/) {
      $self->msg(420);
      return;
    }

    my ($head, $body, $date) = $self->{_group}->get($ano);
    my ($msgid) = ($head =~ /^Message-Id:\s*(<\S+>)/im);

    {                           # fake nnml header
      my %ano = msgid_to_anos($msgid);
      my @newsgroups = keys %ano;
      $head =~ s/^X-nnml-groups:.*\n//mig;
      my $newsgroups = sprintf("X-nnml-groups: %s\n", join(', ', @newsgroups));
      $head .= $newsgroups;
    }

    if ($body) {
      $self->{_article} = $ano;
      if ($cmd eq 'article') {
        $self->msg(220,$ano, $msgid);
        $self->output($head, "\n", $body);
      } elsif ($cmd eq 'head') {
        $self->msg(225,$ano, $msgid);
        $self->output($head);
      } elsif ($cmd eq 'date') {
        $self->msg(288,$date >> 16, $date & 0xfffff, $ano, $msgid);
        return;
      } else {
        $self->msg(222,$ano, $msgid);
        $self->output($body);
      }
      $self->end;
    } else {
      $self->msg(423, $self->{_group}->name);
    }
  }
}

sub post {1;}                   # tbs

sub cmd_ihave {
  my ($self, $msgid) = @_;

  unless ($self->post) {
    $self->msg(437);
    return;
  }
  if (article_msgid($msgid)) {
    $self->msg(435);
    return;
  }
  $self->msg(335);
  $self->accept_article($msgid);
}

sub cmd_post {
  my $self = shift;

  unless ($self->post) {
    $self->msg(440);
    return;
  }
  $self->msg(340);
  $self->accept_article();
}


sub accept_article {            # $extra_group also allows overwriting
  my ($self, $msgid, $extra_group) = @_;
  my $art;

  if ($art = $self->{_fh}->read_until_dot()) {
    $art = join '', @$art;
  } else {                      # won't work?
    print "accept_article() timed out\n";
    $self->msg(441);
    return;
  }
  my $create = NNML::Auth::perm($self,'create');

  if ($self->{slave}) {
    $self->msg(spool_article($Config->spool, $art, $msgid,
                             $extra_group, $create));
  } else {
    my ($code, @msg) = inject_article($art, $msgid, $extra_group, $create);
    unless ($code =~ /^2/) {
      spool_article($Config->bad, $art, $msgid, $extra_group, $create);
    }
    $self->msg($code, @msg);
  }
}

sub spool_article {
  my ($spool, $art, $msgid, $extra_group, $create) = @_;
  my $sf    = new IO::File ">> $spool";

  if ($sf) {
    $sf->printf("$;$;$;$;\t%s\t%s\t%d\n", $msgid, $extra_group, $create);
    $sf->print($art);
    return(240);
  } else {
    return(441, "Could not spool article: $!")
  }
}

sub cmd_xunspool {               # 289 %d/%d articles unspooled
  my $self = shift;

  unless (NNML::Auth::perm($self,'create')) {
    $self->msg(480, "'Need create power'");
    return;
  }
  my ($no_art, $bad) = NNML::Server::unspool();
  $self->msg(289, $no_art, $no_art-$bad);
}

sub NNML::Server::unspool {
  my ($no_art, $bad);
  my $spool = $Config->spool;
  my $sf    = new IO::File "< $spool";

  NNML::Auth::_update();          # just for the message
  NNML::Active::_update();        # just to make sure
  if ($sf) {
    local $/  = "$;$;$;$;\t";
    my $ent;

    while (defined ($ent = <$sf>)) {
      chomp($ent);
      next unless $ent;
      my($ctl, $art) = split /\n/, $ent, 2;
      my ($msgid, $extra_group, $create) = split /\t/, $ctl;

      $no_art++;
      my ($code, @msg) = inject_article($art, $msgid, $extra_group, $create);
      unless ($code =~ /^2/) {
        spool_article($Config->bad, $art, $msgid, $extra_group, $create);
        $bad++;
      }
    }
    $sf->close;
    rename $spool, "$spool~"
      or warn "Could not rename '$spool': $!\n";
  }
  return($no_art, $bad);
}

sub inject_article {
  my ($art, $msgid, $extra_group, $create) = @_;
  my %head = (
              subject         => '',
              from            => '',
              date            => '',
              'message-id'    => $msgid || '',
              references      => '',
              lines           => 0,
              xref            => '',
              'x-nnml-groups' => '',
              newsgroups      => '',
             );
  my $header;

  # done by Net::Cmd now
  #$art =~ s/\.\r?\n$//;
  #$art =~ s/\r//g;
  #$art =~ s/^\.\././mg;

  my ($head, $body) = split /^$/m, $art, 2;

  my $headcopy = $head;
  $headcopy =~ s{\s*\n\s+}{ }g;    # fold continue lines
  my ($fron, %thead) = split /^(\S+):/m, $headcopy;
  for (keys %thead) {
    my $val = $thead{$_};
    $val =~ s/\s/ /;
    $val =~ s/^\s+//;
    $val =~ s/\s+$//;
    $head{lc $_} = $val if exists $head{lc $_};
  }
  unless ($head{lines}) {
    $head{lines} = ($body =~ m/(\n)/g);
  }
  unless ($head{'message-id'}) {
    $head{'message-id'} = sprintf "<%d\@unknown%s>", time, $HOST;
    $head .= "Message-Id: $head{'message-id'}\n";
  } else {
    $head{'message-id'} =~ s/^\s+//;
    $head{'message-id'} =~ s/\s+$//;
  }
  for (keys %head) {
    printf "%-15s %s\n", $_, $head{$_} if $head{$_};
  }
  my @newsgroups = split /,\s*/, $head{'x-nnml-groups'};
  unless (@newsgroups) {
    @newsgroups = split /,\s*/, $head{newsgroups};
  }

  my $file;
  if ($extra_group) {
    my %all = msgid_to_anos($head{'message-id'});
    @newsgroups = keys %all;
    for (@newsgroups) {
      my $any   = $newsgroups[0];
      my $group = $ACTIVE->group($any);
      my $dir   = $group->dir;
      if (-f "$dir/$all{$any}") {
        $file = "$dir/$all{$any}";
        last;
      }
    }
    push @newsgroups, $extra_group unless exists $all{$extra_group};
  }
  unless (@newsgroups) {
    return(441, "No newsgroups specified");
  }
  if (!$extra_group and article_msgid($head{'message-id'})) {
    print "POSTER lied about 'message-id'}\n";
    return(441, "alreday have $head{'message-id'}");
  }

  unless ($ACTIVE->accept_article(\%head, $head, $body, $create, $file,
                                  $extra_group,
                                  @newsgroups)) {
    return(441, "Something went wrong");
  }
  if ($extra_group) {
    my %all = msgid_to_anos($head{'message-id'});
    if ($all{$extra_group}) {
      return(287,$all{$extra_group},$extra_group);
    } else {
      return(441, "Article '$head{'message-id'}' not arrived in $extra_group");
    }
  } else {
    return(240);
  }
}

sub article_msgid {
  my $msgid = shift;
  my ($groupname);
  my %ano = msgid_to_anos($msgid);
  my @newsgroups = keys %ano;
  my ($head, $body);

  for $groupname (@newsgroups) {
    my $group = $ACTIVE->group($groupname);

    ($head, $body) = $group->get($ano{$groupname});
    last if defined $head;
  }
  return unless $head;
  $head =~ s/^X-nnml-groups:.*\n//mig;
  my $newsgroups = sprintf("X-nnml-groups: %s\n", join(', ', @newsgroups));
  return $head . $newsgroups, $body;
}

sub msgid_to_anos {
  my $msgid = shift;
  my $group;
  my %ano;
  for $group ($ACTIVE->groups) {
    my $ano = $group->article_by_id($msgid);
    if (defined $ano) {
      $ano{$group->name} = $ano;
    }
  }
  %ano;
}

sub cmd_xtest {
  my ($self,$msgid) = @_;
  my %anos = msgid_to_anos(@_);
  my ($grp, $ano);

  while (($grp, $ano) = each %anos) {
    printf "%s %d\n", $grp, $anos{$grp};
  }
}

sub to_time {
  my ($date, $time, $gmt) = @_;

  return unless defined $date;
  if (length($date)<8) {
    $date =~ m/^(\d\d)/;
    if ($1 > 30) {
      $date = "19$date";          # not strictly RCS 977
    } else {
      $date = "20$date";          # not strictly RCS 977
    }
  }
  unless (defined $time) {
    $time = "000000";
  }

  $date .= $time;
  my ($year,$mon,$mday,$hours,$min,$sec) =
    ($date =~ m/^(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)$/);
  return unless defined $sec;

  my $ltime;
  $mon--;
  if (defined $gmt) {
    eval { $ltime = timegm($sec,$min,$hours,$mday,$mon,$year) };
  } else {
    eval { $ltime = timelocal($sec,$min,$hours,$mday,$mon,$year)};
  }
  return if $@ ne '';
  return $ltime;
}


# read status messages
my $line;
while (defined ($line = )) {
  chomp($line);
  my ($cmd, $msg) = split ' ', $line, 2;
  last unless $cmd;
  $HELP{$cmd} = $msg;
}
while (defined ($line = )) {
  chomp($line);
  next unless $line =~ /^\d/;
  my ($code, $msg) = split ' ', $line, 2;
  $MSG{$code} = $msg;
}


1;

__DATA__