scripts/Chiark/NNTP.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         $? = 0;
  58         $ns = `cat /etc/nntpserver`;
  59         die if $?;
  60         chomp($ns);
  61     }
  62     my $port = (getservbyname("nntp", "tcp"))[2];
  63     $ns = inet_aton($ns);
  64     my $proto = getprotobyname("tcp");
  65     my $paddr = sockaddr_in($port, $ns);
  66
  67     my $sock = new IO::Handle;
  68     socket($sock,PF_INET,SOCK_STREAM,$proto) or die "socket: $!";
  69     connect($sock,$paddr) or die "connect: $!";
  70
  71     $sock->autoflush(1);
  72
  73     return bless { S => $sock, V => $verbose };
  74 }
  75
  76 sub banner_reader ($) {
  77     my ($c) = @_;
  78     my ($code,$l) = $c->getline();
  79     $code =~ /^2\d\d/ or die "no initial greeting from server\n";
  80     $c->docmd("MODE READER");
  81 }
  82
  83 sub disconnect ($) {
  84     my ($c) = @_;
  85     close $c->{S};
  86 }
  87
  88 sub putline ($$) {
  89     my ($c, $line) = @_;
  90     my $s = $c->{S};
  91     my $v = $c->{V};
  92     print $v ">>> $line\n" if $v;
  93     print $s "$line\r\n";
  94 }
  95
  96 sub getline_raw ($) {
  97     my ($c) = @_;
  98     my $s = $c->{S};
  99     my $l = <$s>;
 100     return $l;
 101 }
 102
 103 sub getline ($) {
 104     my ($c) = @_;
 105     my $v = $c->{V};
 106     my $l = $c->getline_raw();
 107     $l =~ s/[\r\n]*$//s;
 108     my $code = substr($l,0,3);
 109     print $v "<<< $l\n" if $v;
 110     return ($code,$l);
 111 }
 112
 113 sub docmd ($$;$) {
 114     my ($c,$cmd,$nocheck) = @_;
 115     my ($code,$l);
 116     for my $n (0,1) {
 117         $c->putline($cmd);
 118         ($code,$l) = $c->getline();
 119         if ($code eq "480") { $c->auth(); } else { last; }
 120     }
 121     if (!$nocheck) {
 122         $code =~ /^2\d\d/ or die "failed on `$cmd':\n$l\n";
 123     }
 124     return ($code,$l);
 125 }
 126
 127 sub auth ($) {
 128     my ($c) = @_;
 129     # Authentication.
 130     return if $c->{Authed}++;
 131     my $auth = $ENV{"NNTPAUTH"};
 132     if (defined $auth) {
 133         $c->putline("AUTHINFO GENERIC $auth");
 134         pipe AUTHSTDIN, TOAUTH or die "unable to create pipes";
 135         pipe FROMAUTH, AUTHSTDOUT or die "unable to create pipes";
 136         flush STDOUT;
 137         my $pid = fork;
 138         if (!defined $pid) {
 139             die "unable to fork for authentication helper";
 140         } elsif ($pid == 0) {
 141             # we are child
 142             $c->{V} = undef if $c->{V} eq 'STDOUT';
 143             $ENV{"NNTP_AUTH_FDS"} = "0.1";
 144             open STDIN, "<&AUTHSTDIN";
 145             open STDOUT, ">&AUTHSTDOUT";
 146             close $c->{S};
 147             exec $auth;
 148             die $!;
 149         }
 150         # we are parent
 151         close AUTHSTDIN;
 152         close AUTHSTDOUT;
 153         autoflush TOAUTH 1;
 154         my ($code,$l) = $c->getline(); print TOAUTH "$l\n";
 155         while (<FROMAUTH>) {
 156             s/[\r\n]*$//s;
 157             $c->putline($_);
 158             ($code,$l) = $c->getline();
 159             print TOAUTH "$l\n";
 160         }
 161         die "failed authentication\n" unless $? == 0;
 162     }
 163 }
 164
 165 1;