1    #!/usr/bin/perl -Tw
2    $|++;
3    use strict;
4    use CGI qw(:standard escapeHTML);
5    use HTTP::Daemon;
6    use Net::NNTP;
7    use URI::Find;
8    use Mail::Internet;
9    
10    ## config
11    my $PORT = 42084;            # at what port
12    my $TIMEOUT = 600;           # number of quiet seconds before abort
13    my $NNTP = "news.my-isp.comm";  # news-server
14    ## end config
15    
16    my ($HOST) = $ENV{SERVER_NAME} =~ /(.*)/s; # untaint
17    
18    my $d = do {
19      local($^W) = 0;
20      new HTTP::Daemon (LocalAddr => $HOST, LocalPort => $PORT,
            Reuse => 1)
21    };
22    my $url = $d ? $d->url : "http://$HOST:$PORT";
23    
24    my $SELF_URL = self_url;        # for restarting when server breaks
25    my $ICONS = self_url(-base => 1)."/icons";
26    
27    print redirect($url);
28      
29    exit 0 unless defined $d;       # do we need to become the server?
30    
31    defined(my $pid = fork) or die "Cannot fork: $!";
32    exit 0 if $pid;                 # I am the parent
33    close(STDOUT);
34    
35    my $nntp = Net::NNTP->new($NNTP);
36    $nntp->reader if $nntp;
37    
38    ## the main loop
39    {
40      alarm($TIMEOUT);              # (re-)set the deadman time
41      my $c = $d->accept or redo;   # $c is a connection
42      select $c;                    # default for print
43      my $r = $c->get_request;      # $r is a request
44      unless ($r) {
45        warn "cannot get request", $c->reason;
46        redo;
47      }
48    
49      (my $code = $r->url->epath) =~ s{^/}{};
50      $c->send_basic_header;
51      $CGI::Q = new CGI $r->content;
52    
53      print header, start_html("read news");
54    
55      unless ($nntp) {
56        print "Sorry, the NNTP server is unavailable!", br,
57          a({-href => $SELF_URL}, "[Start over]");
58        close $c;
59        redo;
60      }
61    
62      my ($group, $article, $direction, $number, $min, $max);
63      unless (($group, $article, $direction) =
64              $code =~ /\A([a-z0-9.]+)\/(?:(\d+)(-\w+)?)?\z/ and
65              ($number, $min, $max) = $nntp->group($group)) {
66        print h2("Select a group");
67        my $active = $nntp->active(rec.humor.*");
68        print ul(map li(a({-href => "/$_/"}, escapeHTML("[$_]"))),
69                 sort keys %$active);
70        close $c;
71        redo;
72      }
73      ## we have a valid group:
74      print h2("Group ", escapeHTML($group));
75      $article = $max unless defined $article; # if entering group
76      $article = $min if $article < $min;
77      $article = $max if $article > $max;
78      ($article) = $nntp->message =~ /^(\d+)/
79        if $nntp->nntpstat($article); # prepare for next/prev
80      if ($direction) {
81        if ($direction eq "-prev") {
82          ($article) = $nntp->message =~ /^(\d+)/ if $nntp->last;
83        } elsif ($direction eq "-next") {
84          ($article) = $nntp->message =~ /^(\d+)/ if $nntp->next;
85        }                # might add other cases here or error checking
86      }
87      ## navigation box:
88      print table({-border => 0, -cellspacing => 0, -cellpadding => 2},
89                  Tr(td("&nbsp;"),
90                     td(a({-href => "/"}, img({-src => 
                                 "$ICONS/up.gif"}))),
91                     td("&nbsp;")),
92                  Tr(td($article > $min
93                        ? a({-href => "/$group/$article-prev"},
94                            img({-src => "$ICONS/left.gif"}))
95                        : img({-src => "$ICONS/left.gif"})),
96                     td("&nbsp;"),
97                     td($article < $max
98                        ? a({-href => "/$group/$article-next"},
99                            img({-src => "$ICONS/right.gif"}))
100                        : img({-src => "$ICONS/right.gif"}))));
101      ## article:
102      print h2("Article ", escapeHTML($article));
103      next unless my $headbody = $nntp->article;
104      my $mail = Mail::Internet->new($headbody);
105      ## $mail->remove_sig;
106      $mail->tidy_body;
107      print pre(fix(join("", map("$_: ".($mail->head->get($_)),
108                                 qw(Subject Date From)),
109                         "\n", @{$mail->body}),1));
110      close $c;
111      redo;
112    }
113    
114    sub fix {                   # HTML escape, plus find URIs if $_[1]
115      local $_ = shift; return escapeHTML($_) unless shift;
116        # use \001 as "shift out", "shift in", presume data doesn't 
           # have \001
117      find_uris($_, sub {my ($uri, $text) = @_
118                         qq{\1<a href="\1$uri\1" 
                               target=_blank>\1$text\1</a>\1} });
119      s/\G(.*?)(?:\001(.*?)\001)?/escapeHTML($1).(defined $2 ? $2 : 
                  "")/sgie
120      $_;
121    }