File Coverage

blib/lib/Net/RGTP.pm

Criterion	Covered	Total	%
statement	266	326	81.6
branch	87	130	66.9
condition	20	28	71.4
subroutine	24	26	92.3
pod	12	12	100.0
total	409	522	78.3

# Net::RGTP                    -*- cperl -*-
#
# This program is free software; you may distribute it under the same
# conditions as Perl itself.
#
# Copyright (c) 2005 Thomas Thurman

################################################################

package Net::RGTP;

use strict;
use warnings;
use vars qw(@ISA $VERSION);

use Socket 1.3;
use IO::Socket;
use Net::Cmd;
use Digest::MD5 qw(md5_hex);

$VERSION = '0.10';
@ISA     = qw(Exporter Net::Cmd IO::Socket::INET);

use constant GROGGS => 'rgtp-serv.groggs.group.cam.ac.uk';
use constant RGTP => 'rgtp(1431)';

################################################################

sub new
{
  my $package  = shift;
  my %args  = @_;

  my $self = $package->SUPER::new(PeerAddr => $args{Host} || GROGGS,
				  PeerPort => $args{Port} || RGTP,
				  LocalAddr => $args{'LocalAddr'},
				  Proto    => 'tcp',
				  Timeout  => defined $args{Timeout}?
				                  $args{Timeout}: 120
				 ) or return undef;

  $self->debug(100) if $args{'Debug'};

  unless ($self->response) {
    $@ = "Couldn't get a response from the server";
    return undef;
  }

  ${*$self}{'net_rgtp_groggsbug'} = $self->message =~ /GROGGS system/;

  if ($self->code()<230 || $self->code()>232) {
    $@ = "Not an RGTP server";
    return undef;
  }

  $self->_set_alvl;

  $self;
}

sub access_level {
  my $self = shift;

  return ${*$self}{'net_rgtp_status'};
}

sub latest_seq {
  my $self = shift;

  return ${*$self}{'net_rgtp_latest'};
}

sub motd {
  my $self = shift;

  $self->command('MOTD');
  $self->_read_item(no_parse_headers=>1,
		    motd=>1);
}

sub item {
  my ($self, $itemid) = @_;

  return $self->motd if $itemid eq 'motd';

  return undef unless _is_valid_itemid($itemid);

  $self->command('ITEM', $itemid);
  $self->_read_item;
}

sub quick_item {
  my ($self, $itemid) = @_;

  return $self->motd if $itemid eq 'motd';

  my %result = ();

  $self->command('STAT', $itemid);
  $self->response;

  my ($parent, $child, $edit, $reply, $subject) =
    $self->message =~ /^([A-Za-z]\d{7}|\s{8}) ([A-Za-z]\d{7}|\s{8}) ([0-9a-fA-F]{8}|\s{8}) ([0-9a-fA-F]{8}) (.*)$/;

  $result{'parent' } = $parent    if $parent ne '        ';
  $result{'child'  } = $child     if $child  ne '        ';
  $result{'edit'   } = hex($edit) if $edit   ne '        ';
  $result{'reply'  } = hex($reply);
  $result{'subject'} = $subject;

  \%result;
}

sub login {
  my ($self, $userid, $secret) = @_;

  $userid ||= 'guest';

  $self->command('USER', $userid);
  $self->response;

  # Did they let us in for just saying who we were?
  if ($self->code >= 230 && $self->code <= 233) {
    if (defined $secret) {
      $@ = 'Unexpected lack of security-- possible man in the middle attack?';
      return undef;
    }

    return $self->_set_alvl;
  }

  if ($self->code eq '500') {
    $@ = 'Already logged in';
    return undef;
  }
  $self->_expect_code('130');

  my ($algorithm) = $self->message =~ /^(.*?) /;
  if ($algorithm eq 'MD5') {
    $@ = "Unknown algorithm: $algorithm";
  }

  $self->response;
  $self->_expect_code('333');
  my ($server_nonce) = $self->message =~ /([a-zA-Z0-9]{32})/;
  $server_nonce = pack("H*", $server_nonce);

  $secret = pack("H*", $secret);

  my $flipped_secret = '';
  for (my $i=0; $i
    $flipped_secret .= chr((~ord(substr($secret,$i,1)) & 0xFF));
  }

  my $munged_userid = substr($userid, 0, 16);
  while (length($munged_userid)<16) {
    $munged_userid .= chr(0);
  }

  my $client_nonce = '';
  for (my $i=0; $i<16; $i++) {
    $client_nonce .= chr(int(rand(256)));
  }

  my $client_hash = md5_hex($client_nonce,
			    $server_nonce,
			    $munged_userid,
			    $flipped_secret);

  my $server_hash = md5_hex($server_nonce,
			    $client_nonce,
			    $munged_userid,
			    $secret);

  # Now we prove to the server that we know the secret...

  $self->command('AUTH', $client_hash, unpack('H*',$client_nonce));

  # ...and it proves the same to us.

  $self->response;

  unless ($server_hash eq substr(lc($self->message), 0, 32)) {
    $@ = "server failed to authenticate to us";
    return undef;
  }

  $self->response;

  return $self->_set_alvl;
}

sub items {
  my $self = shift;
  my $latest_seq = ${*$self}{'net_rgtp_latest'} || 0;

  if (defined ${*$self}{'net_rgtp_latest'}) {
    $self->command('INDX', sprintf('#%08x', ${*$self}{'net_rgtp_latest'}+1));
  } else {
    $self->command('INDX');
    ${*$self}{'net_rgtp_index'} = {};
  }

  $self->response;

  if ($self->code eq '531') {
    $@ = 'No reading access';
    return undef;
  }
  $self->_expect_code('250');

  for my $line (@{$self->read_until_dot}) {
    my $seq = hex(substr($line, 0, 8));
    my $timestamp = hex(substr($line, 9, 8));
    my $itemid = substr($line, 18, 8);
    my $from = substr($line, 27, 75);
    my $type = substr($line, 103, 1);
    my $subject = substr($line, 105);

    $from =~ s/\s*$//;
    $subject =~ s/\s*$//;

    if ($type eq 'M') {
      $itemid = 'motd';
      $subject = 'Message of the Day';
      $type = 'I';
    }

    if ($type eq 'C') {
      ${*$self}{'net_rgtp_childlink'} = $itemid;
    } elsif ($type eq 'F') {
      if (defined ${*$self}{'net_rgtp_childlink'}) {
	${*$self}{'net_rgtp_index'}
	  { ${*$self}{'net_rgtp_childlink'} }{'child'} = $itemid;
	${*$self}{'net_rgtp_index'}
	  { $itemid }{'parent'} = ${*$self}{'net_rgtp_childlink'};
	delete ${*$self}{'net_rgtp_childlink'};
      }
    }

    if ($type eq 'R' or $type eq 'I' or $type eq 'C') {
      ${*$self}{'net_rgtp_index'}{ $itemid }{'subject'} = $subject;
      ${*$self}{'net_rgtp_index'}{ $itemid }{'posts'}++;
      ${*$self}{'net_rgtp_index'}{ $itemid }{'timestamp'} = $timestamp;
      ${*$self}{'net_rgtp_index'}{ $itemid }{'seq'} = $seq;
    }

    $latest_seq = $seq if $seq > $latest_seq;

  }

  ${*$self}{'net_rgtp_latest'} = $latest_seq;

  ${*$self}{'net_rgtp_index'};

}

sub state {
  my ($self, $setting) = @_;

  if (defined $setting) {
    if (defined $setting->{'latest'}) {
      ${*$self}{'net_rgtp_latest'} = $setting->{'latest'};
      ${*$self}{'net_rgtp_index'}  = $setting->{'index'};
    } else {
      delete ${*$self}{'net_rgtp_latest'};
      delete ${*$self}{'net_rgtp_index'};
    }
  } else {
    if (defined ${*$self}{'net_rgtp_latest'}) {
      return {
	      latest => ${*$self}{'net_rgtp_latest'},
	      index  => ${*$self}{'net_rgtp_index'},
	     };
    } else {
      return {
	      index  => {},
	     };
    }
  }
}

sub post {

  my ($self, $itemid, $text, %args) = @_;

  my $grogname = $args{'Grogname'} || ' ';
  my $seq;

  my $item_was_full = $self->item_is_full;

  delete ${*$self}{'net_rgtp_item_is_full'};
  delete ${*$self}{'net_rgtp_item_has_grown'};

  $self->command('DATA');
  $self->response;

  die "No posting access" if $self->code eq '531';
  $self->_expect_code('150');

  $text =~ s/\n\./\n\.\./g; # dot-doubling

  $self->datasend("$grogname\n");
  $self->datasend($text);
  $self->dataend;

  return undef if $self->_malformed_posting;
  $self->_expect_code('350');

  if ($itemid eq 'new' || $itemid eq 'continue') {

    my $subject = $args{'Subject'}
      or die "Need a subject line";

    if ($itemid eq 'continue') {
      die "We haven't reached the end of an item"
	unless $item_was_full;

      $self->command('CONT', $subject);
    } else {
      $self->command('NEWI', $subject);
    }

    $self->response;

    return undef if $self->_malformed_posting;

    if ($self->code eq '122') {
      $self->response;
      $self->_expect_code('422');

      ${*$self}{'net_rgtp_item_has_grown'} = 1;

      return undef;
    }

    if ($self->code eq '520') {
      $@ = 'We haven\'t reached the end of an item';
    }

    $self->_expect_code('120');

    $self->response;
    $self->_expect_code('220');
    ($itemid) = $self->message =~ /^([A-Za-z][0-9]{7})/;
    # seq is extracted below.

  } elsif ($itemid eq 'motd') {

    $@ = 'Not implemented';
    return undef;

  } else {

    return undef unless _is_valid_itemid($itemid);

    if (defined $args{'Seq'}) {
      my $quick = $self->quick_item($itemid);

      if ($quick->{'reply'} != $args{'Seq'}) {
	$@ = 'Item has apparently grown';
	${*$self}{'net_rgtp_item_has_grown'} = 1;
	return undef;
      }
    }

    $self->command('REPL', $itemid);
    $self->response;

    return undef if $self->_malformed_posting;

    if ($self->code eq '421') {
      # Item is full.

      ${*$self}{'net_rgtp_item_is_full'} = 1;
      $@ = 'Item is full';
      return undef;
    }

    if ($self->code eq '122') {
      $self->response;
      $self->_expect_code('422');

      ${*$self}{'net_rgtp_item_has_grown'} = 1;
      $@ = 'Item has gone into a continuation';
      return undef;
    }

    $self->_expect_code('220');

    # So, success!

  }

  ($seq) = $self->message =~ /([A-Fa-f0-9]{8})  /;

  if (wantarray) {
    return ($itemid, hex($seq));
  } else {
    return $itemid;
  }
}

sub item_is_full {
  my ($self) = @_;

  return defined ${*$self}{'net_rgtp_item_is_full'};
}

sub item_has_grown {
  my ($self) = @_;

  return defined ${*$self}{'net_rgtp_item_has_grown'};
}

################################################################
# INTERNAL ROUTINES

sub _read_item {
  my $self = shift;
  my %args = @_;
  my %result = ();
  my @responses = ();
  my $current_response = ();
  my ($seq, $timestamp);

  $self->response;
  die "No reading access" if $self->code eq '531';
  return undef            if $self->code eq '410';
  $self->_expect_code('250');

  my $status = $self->getline;

  if ($args{'motd'}) {
    ($seq, $timestamp) =
      $status =~ /^([0-9a-fA-F]{8}|\s{8}) ([0-9a-fA-F]{8})/;

    if (${*$self}{'net_rgtp_groggsbug'}) {
      # They have it backwards!
      $result{'seq'} = hex($timestamp);
      $result{'timestamp'} = hex($seq);
    } else {
      $result{'seq'} = hex($seq);
      $result{'timestamp'} = hex($timestamp);
    }
  } else {
    my ($parent, $child, $edit, $reply) =
      $status =~ /^([A-Za-z]\d{7}|\s{8}) ([A-Za-z]\d{7}|\s{8}) ([0-9a-fA-F]{8}|\s{8}) ([0-9a-fA-F]{8})/;

    $result{'parent'} = $parent    if $parent ne '        ';
    $result{'child' } = $child     if $child  ne '        ';
    $result{'edit'  } = hex($edit) if $edit   ne '        ';
    $result{'reply' } = hex($reply);
  }

  for my $line (@{$self->read_until_dot}) {
    if (($seq, $timestamp) = $line =~ /^\^([0-9a-fA-F]{8}) ([0-9a-fA-F]{8})/) {
      push @responses, $current_response if $current_response;
      $current_response = { seq=>hex($seq), timestamp=>hex($timestamp) };

    } else {
      $line =~ s/^\^\^/\^/;
      $line =~ s/^\.\./\./;
      $current_response->{'text'} .= $line;
    }
  }

  $current_response->{'text'} =~ s/\n\n$/\n/;

  push @responses, $current_response;

  unless ($args{'no_parse_headers'}) {
    for my $response (@responses) {

      $response->{'text'} =~ s/\n\n$/\n/;

      my $username;
      if (($username) = $response->{'text'} =~ /^.* from (.*) at .*\n/) {

	if ($username =~ /\(.*\)$/) {
	  ($response->{'grogname'}, $response->{'poster'}) =
	    $username =~ /^(.*) \((.*)\)$/;
	} else {
	  $response->{'poster'} = $username;
	  if ($response->{'text'} =~ /From (.*)\n/) {
	    $response->{'grogname'} = $1;
	  }
	}

      }

      if ($response->{'text'} =~ /Subject: (.*)\n/) {
	$result{'subject'} = $1;
      }

      $response->{'text'} =~ s/^(.|\r|\n)*?\r?\n\r?\n//;
    }
  }

  $result{'posts'} = \@responses;

  if ($args{'motd'}) {
    $result{'posts'}[0]->{'seq'} = delete $result{'seq'};
    $result{'posts'}[0]->{'timestamp'} = delete $result{'timestamp'};
  }

  \%result;
}

sub _is_valid_itemid {
  if (shift =~ /^[A-Za-z]\d{7}$/) {
    return 1;
  } else {
    $@ = 'Invalid itemid';
    return 0;
  }
}

sub _set_alvl {
  my $self = shift;

  die "Expected status response"
    if $self->code()<230 || $self->code()>233;

  ${*$self}{'net_rgtp_status'} = $self->code()-230;
}

sub _expect_code {
  my ($self, $expectation) = @_;

  if ($self->code ne $expectation) {
    die "Low-level protocol error: expected $expectation and got ".$self->code;
  }
}

sub _malformed_posting {

  my $self = shift;

  if ($self->code eq '423') { $@ = 'Malformed text';     return 1; }
  if ($self->code eq '424') { $@ = 'Malformed subject';  return 1; }
  if ($self->code eq '425') { $@ = 'Malformed grogname'; return 1; }

  return 0;
}

1;

__END__