keitairc

   1 #!/usr/bin/perl
   2 # keitairc
   3 # $Id: keitairc,v 1.17 2004-03-23 17:55:41 ishikawa Exp $
   4 #
   5 # Copyright (c) 2003 Jun Morimoto <morimoto@xantia.citroen.org>
   6 # This program is covered by the GNU General Public License 2
   7 #
   8 # Depends: libjcode-pm-perl, libpoe-component-irc-perl,
   9 #   liburi-perl, libwww-perl, libappconfig-perl
  10
  11 my $rcsid = q$Id: keitairc,v 1.17 2004-03-23 17:55:41 ishikawa Exp $;
  12 my ($version) = $rcsid =~ m#,v ([0-9.]+)#;
  13
  14 use strict;
  15 use Jcode;
  16 use POE;
  17 use POE::Component::Server::TCP;
  18 use POE::Filter::HTTPD;
  19 use POE::Component::IRC;
  20 use URI::Escape;
  21 use HTTP::Response;
  22 use AppConfig qw(:argcount);
  23
  24 my $config = AppConfig->new(
  25                             {
  26                                 CASE => 1,
  27                                 GLOBAL => {
  28                                     ARGCOUNT => ARGCOUNT_ONE,
  29                                 }
  30                             },
  31                             qw(irc_nick irc_username irc_desc
  32                                irc_server irc_port irc_password
  33                                web_port web_title web_lines web_root
  34                                web_username web_password show_newmsgonly)
  35                             );
  36
  37 $config->file('/etc/keitairc');
  38 $config->file($ENV{'HOME'} . '/.keitairc');
  39 $config->args;
  40
  41 my $docroot = '/';
  42 if(defined $config->web_root){
  43     $docroot = $config->web_root;
  44 }
  45
  46 # join \e$B$7$F$$$k%A%c%M%k$NL>>N$r5-O?$9$k%O%C%7%e\e(B
  47 my %channel_name;
  48
  49 # \e$B%A%c%M%k$N2qOCFbMF$r5-O?$9$k%O%C%7%e\e(B
  50 my (%channel_buffer, %channel_recent);
  51
  52 # \e$B3F%A%c%M%k$N:G=*%"%/%;%9;~9o!":G?7H/8@;~9o\e(B
  53 my %mtime;
  54
  55 # unread lines
  56 my %unread;
  57
  58 # chk
  59 my ($send_chk, $update_chk);
  60
  61 # irc component
  62 POE::Component::IRC->new('keitairc');
  63 POE::Session->new(
  64                   _start => \&on_irc_start,
  65                   irc_join => \&on_irc_join,
  66                   irc_part => \&on_irc_part,
  67                   irc_public => \&on_irc_public,
  68                   irc_notice => \&on_irc_notice,
  69                   );
  70
  71 # web server component
  72 POE::Component::Server::TCP->new(
  73                                  Alias => 'keitairc',
  74                                  Port => $config->web_port,
  75                                  ClientFilter => 'POE::Filter::HTTPD',
  76                                  ClientInput => \&on_web_request
  77                                  );
  78
  79 $poe_kernel->run();
  80 exit 0;
  81
  82 ################################################################
  83 sub on_irc_start{
  84     my $kernel = $_[KERNEL];
  85     $kernel->post('keitairc' => 'register' => 'all');
  86     $kernel->post('keitairc' => 'connect' => {
  87         Nick => $config->irc_nick,
  88         Username => $config->irc_username,
  89         Ircname => $config->irc_desc,
  90         Server => $config->irc_server,
  91         Port => $config->irc_port,
  92         Password => $config->irc_password
  93     });
  94 }
  95
  96 ################################################################
  97 sub on_irc_join{
  98     my ($kernel, $who, $channel) = @_[KERNEL, ARG0, ARG1];
  99     $channel_name{$channel}++;
 100 }
 101
 102 ################################################################
 103 sub on_irc_part{
 104     my ($kernel, $who, $channel) = @_[KERNEL, ARG0, ARG1];
 105     $who =~ s/!.*//;
 106
 107     # chop off after the gap (bug workaround of POE::Filter::IRC)
 108     $channel =~ s/ .*//;
 109
 110     if ($who eq $config->irc_nick) {
 111        delete $channel_name{$channel};
 112     } else {
 113        &add_message($channel, 'SYSOP', $who . ' leaves');
 114     }
 115 }
 116
 117 ################################################################
 118 sub on_irc_public{
 119     my ($kernel, $who, $channel, $msg) = @_[KERNEL, ARG0 .. ARG2];
 120     $who =~ s/!.*//;
 121     $channel = $channel->[0];
 122     $msg = Jcode->new($msg, 'jis')->euc;
 123     &add_message($channel, $who, $msg);
 124 }
 125
 126 ################################################################
 127 sub on_irc_notice{
 128     my ($kernel, $who, $channel, $msg) = @_[KERNEL, ARG0 .. ARG2];
 129     $who =~ s/!.*//;
 130     $channel = $channel->[0];
 131     $msg = Jcode->new($msg, 'jis')->euc;
 132     &add_message($channel, $who, $msg);
 133 }
 134
 135 ################################################################
 136 # $msg \e$B$O\e(B EUC \e$B$K$J$C$F$$$k$O$:\e(B
 137 # $channel \e$B$O\e(B jis \e$B$G$-$F$k$>\e(B
 138 sub add_message{
 139     my($channel, $who, $msg) = @_;
 140
 141     my $message = sprintf('%s %s> %s', &now, $who, $msg);
 142
 143     my @tmp = split("\n", $channel_buffer{$channel});
 144     push @tmp, $message;
 145
 146     my @tmp2 = split("\n", $channel_recent{$channel});
 147     push @tmp2, $message;
 148
 149     if(@tmp > $config->web_lines){
 150         $channel_buffer{$channel} =
 151                 join("\n", splice(@tmp, -$config->web_lines));
 152     }else{
 153         $channel_buffer{$channel} = join("\n", @tmp);
 154     }
 155
 156     if(@tmp2 > $config->web_lines){
 157         $channel_recent{$channel} =
 158                 join("\n", splice(@tmp2, -$config->web_lines));
 159     }else{
 160         $channel_recent{$channel} = join("\n", @tmp2);
 161     }
 162
 163     $mtime{$channel} = time;
 164
 165     # unread lines
 166     $unread{$channel} = @tmp2;
 167
 168     if ($unread{$channel} > $config->web_lines) {
 169         $unread{$channel} = $config->web_lines;
 170     }
 171 }
 172
 173 ################################################################
 174 sub now{
 175     my ($sec,$min,$hour) = localtime(time);
 176     sprintf('%02d:%02d', $hour, $min);
 177 }
 178
 179 ################################################################
 180 sub escape{
 181     local($_) = shift;
 182     s/&/&amp;/;
 183     s/>/&gt;/;
 184     s/</&lt;/;
 185     $_;
 186 }
 187
 188 ################################################################
 189 sub label{
 190     my $accesskey = shift;
 191
 192     if($accesskey < 10){
 193         sprintf('%d ', $accesskey);
 194     }else{
 195         '  ';
 196     }
 197 }
 198
 199 ################################################################
 200 sub index_page{
 201     my $buf;
 202     my $accesskey = 1;
 203
 204     for my $channel (sort {
 205         $mtime{$b} <=> $mtime{$a};
 206     }(keys(%channel_name))){
 207
 208         $buf .= &label($accesskey);
 209
 210         if($accesskey < 10){
 211                 $buf .= sprintf('<a accesskey="%1d" href="%s%s">%s</a>',
 212                                 $accesskey,
 213                                 $docroot,
 214                                 uri_escape($channel),
 215                                 &compact_channel_name($channel));
 216         }else{
 217                 $buf .= sprintf('<a href="%s%s">%s</a>',
 218                                 $docroot,
 219                                 uri_escape($channel),
 220                                 &compact_channel_name($channel));
 221         }
 222
 223         $accesskey++;
 224
 225         # \e$BL$FI9T?t\e(B
 226         if($unread{$channel} > 0){
 227                 $buf .= sprintf(' <a href="%s%s.update">%d</a>',
 228                                 $docroot,
 229                                 uri_escape($channel),
 230                                 $unread{$channel});
 231         }
 232         $buf .= '<br>';
 233     }
 234
 235     $buf .= qq(0 <a href="$docroot" accesskey="0">refresh list</a><br>);
 236     $buf .= qq( - keitairc $version);
 237     $buf;
 238 }
 239
 240 ################################################################
 241 # \e$B%A%c%M%kL>>N$rC;$+$/$9$k\e(B
 242 sub compact_channel_name{
 243     local($_) = shift;
 244
 245     # #name:*.jp \e$B$r\e(B %name \e$B$K\e(B
 246     if(s/:\*\.jp$//){
 247         s/^#/%/;
 248     }
 249
 250     # \e$BKvHx$NC1FH$N\e(B @ \e$B$O<h$k\e(B (for multicast.plm)
 251     s/\@$//;
 252
 253     $_;
 254 }
 255
 256 ################################################################
 257 sub render{
 258     local($_);
 259     my @buf;
 260
 261     my @src = (reverse(split("\n", shift)))[0 .. $config->web_lines];
 262
 263     for (@src){
 264         next unless defined;
 265         next unless length;
 266
 267         $_ = &escape($_);
 268
 269         unless(s,(http://[!-;=-\177]+),<a href="$1">$1</a>,g){
 270             unless(s|(www\.[!-\177]+)|<A HREF="http://$1">$1</A>|g){
 271                 # phone to
 272                 unless(s|(0\d{1,3}[-(]?\d{2,4}[-)]?\d{4})|<a href="tel:$1">$1</a>|g){
 273                     s|(\w[\w.+=-]+\@[\w.-]+[\w])|<a href="mailto:$1">$1</a>|g;
 274                 }
 275             }
 276         }
 277
 278         s/\s+$//;
 279         s/\s+/ /g;
 280         push @buf, $_;
 281     }
 282
 283     '<pre>' . join("\n", @buf) . '</pre>';
 284 }
 285
 286 ################################################################
 287 sub on_web_request{
 288     my ($kernel, $heap, $request) = @_[KERNEL, HEAP, ARG0];
 289
 290     # Filter::HTTPD sometimes generates HTTP::Response objects.
 291     # They indicate (and contain the response for) errors that occur
 292     # while parsing the client's HTTP request.  It's easiest to send
 293     # the responses as they are and finish up.
 294     if($request->isa('HTTP::Response')){
 295         $heap->{client}->put($request);
 296         $kernel->yield('shutdown');
 297         return;
 298     }
 299
 300     if(defined($config->web_username)){
 301         unless($request->headers->authorization_basic eq
 302                $config->web_username . ':' . $config->web_password){
 303
 304             my $response = HTTP::Response->new(401);
 305             $response->push_header(WWW_Authenticate =>
 306                                    qq(Basic Realm="keitairc"));
 307             $heap->{client}->put($response);
 308             $kernel->yield('shutdown');
 309             return;
 310         }
 311     }
 312
 313     my $uri = $request->uri;
 314     my $content = '<html><head>';
 315     $content .= '<meta http-equiv="Cache-Control" content="max-age=0" />';
 316
 317     # POST \e$B$5$l$F$-$?$b$N$OH/8@\e(B
 318     if($request->method =~ /POST/i){
 319         my $message = $request->content;
 320         $message =~ s/^m=//;
 321         $message =~ s/\+/ /g;
 322         $message = uri_unescape($message);
 323
 324         if(length($message)){
 325             $uri =~ s|^/||;
 326             my $channel = uri_unescape($uri);
 327             $poe_kernel->post('keitairc',
 328                               'privmsg',
 329                               Jcode->new($channel)->jis,
 330                               Jcode->new($message)->jis);
 331             &add_message($channel, $config->irc_nick,
 332                          Jcode->new($message)->euc);
 333
 334             # set flag for "send message"
 335             $send_chk = 1;
 336         }
 337     }
 338
 339     if($uri eq '/'){
 340         $content .= '<title>' . $config->web_title . '</title>';
 341         $content .= '</head>';
 342         $content .= '<body>';
 343         $content .= &index_page;
 344     }else{
 345         $uri =~ s|^/||;
 346
 347         $update_chk = ($uri =~ /.*.update/);
 348         if ($update_chk eq 1) {
 349                 $uri =~ s/.update//;
 350         }
 351
 352         my $channel = uri_unescape($uri);
 353
 354         $content .= '<title>' . $config->web_title . ": $channel</title>";
 355         $content .= '</head>';
 356         $content .= '<body>';
 357
 358         $content .= '<a name="1"></a>';
 359         $content .= '<a accesskey="7" href="#1"></a>';
 360
 361         $content .= sprintf('<form action="%s%s" method="post">',
 362                             $docroot, $uri);
 363         $content .= '<input type="text" name="m" size="10">';
 364         $content .= '<input type="submit" accesskey="1" value="OK[1]">';
 365         $content .= qq(<a accesskey="8" href="$docroot">back[8]</a><br>);
 366         # $content .= '<input type="submit" accesskey="1" value="&#63920;">';
 367         $content .= '</form>';
 368
 369         if(defined($channel_name{$channel})){
 370             if(defined($channel_buffer{$channel}) &&
 371                length($channel_buffer{$channel})){
 372                 $content .= '<a accesskey="9" href="#2"></a>';
 373                 if ((($update_chk eq 1)||((defined $config->show_newmsgonly) && ($send_chk eq 1)))) {
 374                   $content .= &render($channel_recent{$channel});
 375                   $content .= sprintf('<a accesskey="5" href="%s%s">
 376                         ..more[5]</a>', $docroot, uri_escape($channel));
 377                 } else {
 378                   $content .= &render($channel_buffer{$channel});
 379                 }
 380                 $content .= '<a name="2"></a>';
 381             }else{
 382                 $content .= 'no message here yet';
 383             }
 384         }else{
 385             $content .= "no such channel";
 386         }
 387
 388         # clear check flags
 389         $send_chk = 0;
 390
 391         # clear unread counter
 392         $unread{$channel} = 0;
 393
 394         # clear recent messages buffer
 395         $channel_recent{$channel} = '';
 396     }
 397
 398     $content .= '</body></html>';
 399
 400     my $response = HTTP::Response->new(200);
 401     $response->push_header('Content-type', 'text/html; charset=Shift_JIS');
 402     $response->content(Jcode->new($content)->sjis);
 403     $heap->{client}->put($response);
 404     $kernel->yield('shutdown');
 405 }
 406
 407 __END__