scripts/ChiarkNNTP.pm

   1 #!/usr/bin/perl
   2
   3 # Originally by Simon Tatham
   4 # Modified by Richard Kettlewell, Colin Watson, Ian Jackson
   5 #
   6 # Copyright -2011 Simon Tatham
   7 # Copyright 2011 Richard Kettlewell
   8 # Copyright 2011 Colin Watson
   9 # Copyright 2011 Ian Jackson
  10 #
  11 # Permission is hereby granted, free of charge, to any person obtaining a
  12 # copy of this software and associated documentation files (the "Software"),
  13 # to deal in the Software without restriction, including without limitation
  14 # the rights to use, copy, modify, merge, publish, distribute, sublicense,
  15 # and/or sell copies of the Software, and to permit persons to whom the
  16 # Software is furnished to do so, subject to the following conditions:
  17 #
  18 # The above copyright notice and this permission notice shall be included in
  19 # all copies or substantial portions of the Software.
  20 #
  21 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  22 # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  23 # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
  24 # SOFTWARE IN THE PUBLIC INTEREST, INC. BE LIABLE FOR ANY CLAIM, DAMAGES OR
  25 # OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
  26 # ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  27 # DEALINGS IN THE SOFTWARE.
  28
  29 use strict qw(subs);
  30 use warnings;
  31
  32 require 5.002;
  33 use Socket;
  34 use FileHandle;
  35
  36
  37 BEGIN {
  38     use Exporter   ();
  39     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
  40
  41     # set the version for version checking
  42     $VERSION     = 1.00;
  43
  44     @ISA         = qw(Exporter);
  45     @EXPORT      = qw(cnntp_connect);
  46     %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
  47
  48     @EXPORT_OK   = qw();
  49 }
  50 our @EXPORT_OK;
  51
  52 sub cnntp_connect ($) {
  53     my ($verbose) = @_;
  54
  55     my $ns=$ENV{'NNTPSERVER'};
  56     if (!defined $ns or !length $ns) {
  57         $ns = `cat /etc/nntpserver`;
  58         chomp($ns);
  59     }
  60     my $port = (getservbyname("nntp", "tcp"))[2];
  61     $ns = inet_aton($ns);
  62     my $proto = getprotobyname("tcp");
  63     my $paddr = sockaddr_in($port, $ns);
  64
  65     my $sock = new IO::Handle;
  66     socket($sock,PF_INET,SOCK_STREAM,$proto) or die "socket: $!";
  67     connect($sock,$paddr) or die "connect: $!";
  68
  69     $sock->autoflush(1);
  70
  71     return bless { S => $sock, V => $verbose };
  72 }
  73
  74 sub banner_reader ($) {
  75     my ($c) = @_;
  76     my ($code,$l) = $c->getline();
  77     $code =~ /^2\d\d/ or die "no initial greeting from server\n";
  78     $c->docmd("MODE READER");
  79 }
  80
  81 sub disconnect ($) {
  82     my ($c) = @_;
  83     close $c->{S};
  84 }
  85
  86 sub putline ($$) {
  87     my ($c, $line) = @_;
  88     my $s = $c->{S};
  89     my $v = $c->{V};
  90     print $v ">>> $line\n" if $v;
  91     print $s "$line\r\n";
  92 }
  93
  94 sub getline_raw ($) {
  95     my ($c) = @_;
  96     my $s = $c->{S};
  97     my $l = <$s>;
  98     return $l;
  99 }
 100
 101 sub getline ($) {
 102     my ($c) = @_;
 103     my $v = $c->{V};
 104     my $l = $c->getline_raw();
 105     $l =~ s/[\r\n]*$//s;
 106     my $code = substr($l,0,3);
 107     print $v "<<< $l\n" if $v;
 108     return ($code,$l);
 109 }
 110
 111 sub docmd ($$;$) {
 112     my ($c,$cmd,$nocheck) = @_;
 113     my ($code,$l);
 114     for my $n (0,1) {
 115         $c->putline($cmd);
 116         ($code,$l) = $c->getline();
 117         if ($code eq "480") { $c->auth(); } else { last; }
 118     }
 119     if (!$nocheck) {
 120         $code =~ /^2\d\d/ or die "failed on `$cmd':\n$l\n";
 121     }
 122     return ($code,$l);
 123 }
 124
 125 sub auth ($) {
 126     my ($c) = @_;
 127     # Authentication.
 128     return if $c->{Authed}++;
 129     my $auth = $ENV{"NNTPAUTH"};
 130     if (defined $auth) {
 131         $c->putline("AUTHINFO GENERIC $auth");
 132         pipe AUTHSTDIN, TOAUTH or die "unable to create pipes";
 133         pipe FROMAUTH, AUTHSTDOUT or die "unable to create pipes";
 134         flush STDOUT;
 135         my $pid = fork;
 136         if (!defined $pid) {
 137             die "unable to fork for authentication helper";
 138         } elsif ($pid == 0) {
 139             # we are child
 140             $c->{V} = undef if $c->{V} eq 'STDOUT';
 141             $ENV{"NNTP_AUTH_FDS"} = "0.1";
 142             open STDIN, "<&AUTHSTDIN";
 143             open STDOUT, ">&AUTHSTDOUT";
 144             close $c->{S};
 145             exec $auth;
 146             die $!;
 147         }
 148         # we are parent
 149         close AUTHSTDIN;
 150         close AUTHSTDOUT;
 151         autoflush TOAUTH 1;
 152         my ($code,$l) = $c->getline(); print TOAUTH "$l\n";
 153         while (<FROMAUTH>) {
 154             s/[\r\n]*$//s;
 155             $c->putline($_);
 156             ($code,$l) = $c->getline();
 157             print TOAUTH "$l\n";
 158         }
 159         die "failed authentication\n" unless $? == 0;
 160     }
 161 }
 162
 163 1;