keitairc

   1 #!/usr/bin/perl
   2 # keitairc
   3 # $Id: keitairc,v 1.25 2004-08-29 12:24:21 morimoto 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.25 2004-08-29 12:24:21 morimoto 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 use constant true => 1;
  25 use constant false => 0;
  26
  27 my $config = AppConfig->new(
  28                             {
  29                                 CASE => 1,
  30                                 GLOBAL => {
  31                                     ARGCOUNT => ARGCOUNT_ONE,
  32                                 }
  33                             },
  34                             qw(irc_nick irc_username irc_desc
  35                                irc_server irc_port irc_password
  36                                au_subscriber_id
  37                                web_port web_title web_lines web_root
  38                                web_username web_password show_newmsgonly)
  39                             );
  40
  41 $config->file('/etc/keitairc');
  42 $config->file($ENV{'HOME'} . '/.keitairc');
  43 $config->args;
  44
  45 my $docroot = '/';
  46 if(defined $config->web_root){
  47     $docroot = $config->web_root;
  48 }
  49
  50 # join \e$B$7$F$$$k%A%c%M%k$NL>>N$r5-O?$9$k%O%C%7%e\e(B
  51 my %channel_name;
  52
  53 # \e$B%A%c%M%k$N2qOCFbMF$r5-O?$9$k%O%C%7%e\e(B
  54 my (%channel_buffer, %channel_recent);
  55
  56 # \e$B3F%A%c%M%k$N:G=*%"%/%;%9;~9o!":G?7H/8@;~9o\e(B
  57 my %mtime;
  58
  59 # unread lines
  60 my %unread_lines;
  61
  62 # chk
  63 my ($message_added);
  64
  65 # irc component
  66 POE::Component::IRC->new('keitairc');
  67 POE::Session->new(
  68                   _start => \&on_irc_start,
  69                   irc_join => \&on_irc_join,
  70                   irc_part => \&on_irc_part,
  71                   irc_public => \&on_irc_public,
  72                   irc_notice => \&on_irc_notice,
  73                   irc_ctcp_action => \&on_irc_ctcp_action,
  74                   );
  75
  76 # web server component
  77 POE::Component::Server::TCP->new(
  78                                  Alias => 'keitairc',
  79                                  Port => $config->web_port,
  80                                  ClientFilter => 'POE::Filter::HTTPD',
  81                                  ClientInput => \&on_web_request
  82                                  );
  83
  84 $poe_kernel->run();
  85 exit 0;
  86
  87 ################################################################
  88 sub on_irc_start{
  89     my $kernel = $_[KERNEL];
  90     $kernel->post('keitairc' => 'register' => 'all');
  91     $kernel->post('keitairc' => 'connect' => {
  92         Nick => $config->irc_nick,
  93         Username => $config->irc_username,
  94         Ircname => $config->irc_desc,
  95         Server => $config->irc_server,
  96         Port => $config->irc_port,
  97         Password => $config->irc_password
  98     });
  99 }
 100
 101 ################################################################
 102 sub on_irc_join{
 103     my ($kernel, $who, $channel) = @_[KERNEL, ARG0, ARG1];
 104     $who =~ s/!.*//;
 105
 106     # chop off after the gap (bug workaround of madoka)
 107     $channel =~ s/ .*//;
 108     my $canon_channel = &canon_name($channel);
 109
 110     $channel_name{$canon_channel} = $channel;
 111     unless ($who eq $config->irc_nick) {
 112       &add_message($channel, undef, "$who joined");
 113     }
 114 }
 115
 116 ################################################################
 117 sub on_irc_part{
 118     my ($kernel, $who, $channel) = @_[KERNEL, ARG0, ARG1];
 119     $who =~ s/!.*//;
 120
 121     # chop off after the gap (bug workaround of POE::Filter::IRC)
 122     $channel =~ s/ .*//;
 123     my $canon_channel = &canon_name($channel);
 124
 125     if ($who eq $config->irc_nick) {
 126        delete $channel_name{$canon_channel};
 127     } else {
 128        &add_message($channel, undef, "$who leaves");
 129     }
 130 }
 131
 132 ################################################################
 133 sub on_irc_public{
 134     my ($kernel, $who, $channel, $msg) = @_[KERNEL, ARG0 .. ARG2];
 135     $who =~ s/!.*//;
 136     $channel = $channel->[0];
 137     $msg = Jcode->new($msg, 'jis')->euc;
 138     &add_message($channel, $who, $msg);
 139 }
 140
 141 ################################################################
 142 sub on_irc_notice{
 143     my ($kernel, $who, $channel, $msg) = @_[KERNEL, ARG0 .. ARG2];
 144     $who =~ s/!.*//;
 145     $channel = $channel->[0];
 146     $msg = Jcode->new($msg, 'jis')->euc;
 147     &add_message($channel, $who, $msg);
 148 }
 149
 150 ################################################################
 151 sub on_irc_ctcp_action{
 152     my ($kernel, $who, $channel, $msg) = @_[KERNEL, ARG0 .. ARG2];
 153     $who =~ s/!.*//;
 154     $channel = $channel->[0];
 155     $msg = sprintf('* %s %s', $who, Jcode->new($msg, 'jis')->euc);
 156     &add_message($channel, '', $msg);
 157 }
 158
 159 ################################################################
 160 # $msg \e$B$O\e(B EUC \e$B$K$J$C$F$$$k$O$:\e(B
 161 # $channel \e$B$O\e(B jis \e$B$G$-$F$k$>\e(B
 162 sub add_message{
 163     my($channel, $who, $msg) = @_;
 164
 165     my $message;
 166     if(length $who){
 167       $message = sprintf('%s %s> %s', &now, $who, $msg);
 168     }else{
 169       $message = sprintf('%s %s', &now, $msg);
 170     }
 171
 172     my $canon_channel = &canon_name($channel);
 173     my @tmp = split("\n", $channel_buffer{$canon_channel});
 174     push @tmp, $message;
 175
 176     my @tmp2 = split("\n", $channel_recent{$canon_channel});
 177     push @tmp2, $message;
 178
 179     if(@tmp > $config->web_lines){
 180         $channel_buffer{$canon_channel} =
 181                 join("\n", splice(@tmp, -$config->web_lines));
 182     }else{
 183         $channel_buffer{$canon_channel} = join("\n", @tmp);
 184     }
 185
 186     if(@tmp2 > $config->web_lines){
 187         $channel_recent{$canon_channel} =
 188                 join("\n", splice(@tmp2, -$config->web_lines));
 189     }else{
 190         $channel_recent{$canon_channel} = join("\n", @tmp2);
 191     }
 192
 193     $mtime{$canon_channel} = time;
 194
 195     # unread lines
 196     $unread_lines{$canon_channel} = scalar(@tmp2);
 197
 198     if($unread_lines{$canon_channel} > $config->web_lines){
 199         $unread_lines{$canon_channel} = $config->web_lines;
 200     }
 201 }
 202
 203 ################################################################
 204 sub now{
 205     my ($sec,$min,$hour) = localtime(time);
 206     sprintf('%02d:%02d', $hour, $min);
 207 }
 208
 209 ################################################################
 210 sub escape{
 211     local($_) = shift;
 212     s/&/&amp;/g;
 213     s/>/&gt;/g;
 214     s/</&lt;/g;
 215     $_;
 216 }
 217
 218 ################################################################
 219 sub label{
 220     my $accesskey = shift;
 221
 222     if($accesskey < 10){
 223         sprintf('%d ', $accesskey);
 224     }else{
 225         '  ';
 226     }
 227 }
 228
 229 ################################################################
 230 sub index_page{
 231     my $buf;
 232     my $accesskey = 1;
 233     my $channel;
 234
 235     for my $canon_channel (sort {
 236         $mtime{$b} <=> $mtime{$a};
 237     }(keys(%channel_name))){
 238         $channel = $channel_name{$canon_channel};
 239
 240         $buf .= &label($accesskey);
 241
 242         if($accesskey < 10){
 243                 $buf .= sprintf('<a accesskey="%1d" href="%s%s">%s</a>',
 244                                 $accesskey,
 245                                 $docroot,
 246                                 uri_escape($channel),
 247                                 &compact_channel_name($channel));
 248         }else{
 249                 $buf .= sprintf('<a href="%s%s">%s</a>',
 250                                 $docroot,
 251                                 uri_escape($channel),
 252                                 &compact_channel_name($channel));
 253         }
 254
 255         $accesskey++;
 256
 257         # \e$BL$FI9T?t\e(B
 258         if($unread_lines{$canon_channel}){
 259                 $buf .= sprintf(' <a href="%s%s,recent">%d</a>',
 260                                 $docroot,
 261                                 uri_escape($channel),
 262                                 $unread_lines{$canon_channel});
 263         }
 264         $buf .= '<br>';
 265     }
 266
 267     $buf .= qq(0 <a href="$docroot" accesskey="0">refresh list</a><br>);
 268
 269     if(grep($unread_lines{$_}, keys %unread_lines)){
 270       $buf .= qq(* <a href="$docroot,recent" accesskey="*">recent</a><br>);
 271     }
 272
 273     $buf .= qq( - keitairc $version);
 274     $buf;
 275 }
 276
 277 ################################################################
 278 # \e$B%A%c%M%kL>>N$rC;$+$/$9$k\e(B
 279 sub compact_channel_name{
 280     local($_) = shift;
 281
 282     # #name:*.jp \e$B$r\e(B %name \e$B$K\e(B
 283     if(s/:\*\.jp$//){
 284         s/^#/%/;
 285     }
 286
 287     # \e$BKvHx$NC1FH$N\e(B @ \e$B$O<h$k\e(B (for multicast.plm)
 288     s/\@$//;
 289
 290     $_;
 291 }
 292
 293 ################################################################
 294 sub canon_name{
 295     local($_) = shift;
 296
 297     tr/A-Z[\\]^/a-z{|}~/;
 298
 299     $_;
 300 }
 301
 302 ################################################################
 303 sub render{
 304     local($_);
 305     my @buf;
 306
 307     my @src = (reverse(split("\n", shift)))[0 .. $config->web_lines];
 308
 309     for (@src){
 310         next unless defined;
 311         next unless length;
 312
 313         $_ = &escape($_);
 314
 315         unless(s,\b(https?://[!-;=-\177]+)\b,<a href="$1">$1</a>,g){
 316             unless(s|\b(www\.[!-\177]+)\b|<a href="http://$1">$1</a>|g){
 317                 # phone to
 318                 unless(s|\b(0\d{1,3})([-(]?)(\d{2,4})([-)]?)(\d{4})\b|<a href="tel:$1$3$5">$1$2$3$4$5</a>|g){
 319                     s|\b(\w[\w.+=-]+\@[\w.-]+[\w]\.[\w]{2,4})\b|<a href="mailto:$1">$1</a>|g;
 320                 }
 321             }
 322         }
 323
 324         s/\s+$//;
 325         s/\s+/ /g;
 326         push @buf, $_;
 327     }
 328
 329     '<pre>' . join("\n", @buf) . '</pre>';
 330 }
 331
 332 ################################################################
 333 sub on_web_request{
 334     my ($kernel, $heap, $request) = @_[KERNEL, HEAP, ARG0];
 335
 336     # Filter::HTTPD sometimes generates HTTP::Response objects.
 337     # They indicate (and contain the response for) errors that occur
 338     # while parsing the client's HTTP request.  It's easiest to send
 339     # the responses as they are and finish up.
 340     if($request->isa('HTTP::Response')){
 341         $heap->{client}->put($request);
 342         $kernel->yield('shutdown');
 343         return;
 344     }
 345
 346     # authorization
 347     unless(defined($config->au_subscriber_id) &&
 348            ($request->header('x-up-subno') eq $config->au_subscriber_id)) {
 349         if(defined($config->web_username)){
 350             unless($request->headers->authorization_basic eq
 351                    $config->web_username . ':' . $config->web_password){
 352                 my $response = HTTP::Response->new(401);
 353                 $response->push_header(WWW_Authenticate =>
 354                                        qq(Basic Realm="keitairc"));
 355                 $heap->{client}->put($response);
 356                 $kernel->yield('shutdown');
 357                 return;
 358             }
 359         }
 360     }
 361
 362     my $uri = $request->uri;
 363     my $content = '<html><head>';
 364     $content .= '<meta http-equiv="Cache-Control" content="max-age=0" />';
 365
 366     # POST \e$B$5$l$F$-$?$b$N$OH/8@\e(B
 367     if($request->method =~ /POST/i){
 368         my $message = $request->content;
 369         $message =~ s/^m=//;
 370         $message =~ s/\+/ /g;
 371         $message = uri_unescape($message);
 372
 373         if(length($message)){
 374             $uri =~ s|^/||;
 375             my $channel = uri_unescape($uri);
 376             $poe_kernel->post('keitairc',
 377                               'privmsg',
 378                               Jcode->new($channel)->jis,
 379                               Jcode->new($message)->jis);
 380             &add_message($channel, $config->irc_nick,
 381                          Jcode->new($message)->euc);
 382             $message_added = true;
 383         }
 384     }
 385
 386     # store and remove attached options from uri
 387     my %option;
 388     {
 389       my @opts = split(',', $uri);
 390       shift @opts;
 391       grep($option{$_} = $_, @opts);
 392       $uri =~ s/,.*//;
 393     }
 394
 395     if($uri eq '/'){
 396       $content .= '<title>' . $config->web_title . '</title>';
 397       $content .= '</head>';
 398       $content .= '<body>';
 399
 400       if($option{recent}){
 401         # recent messages on every channel
 402         for my $channel (sort keys %channel_name){
 403           my $canon_channel = &canon_name($channel);
 404           if(defined($channel_name{$canon_channel}) &&
 405              length($channel_recent{$canon_channel})){
 406             $content .= "<b>$channel_name{$canon_channel}</b>";
 407             $content .= sprintf(' <a href="%s%s">more..</a><br>',
 408                                 $docroot, uri_escape($channel));
 409             $content .= &render($channel_recent{$canon_channel});
 410             $unread_lines{$canon_channel} = 0;
 411             $channel_recent{$canon_channel} = '';
 412             $content .= '<hr>';
 413           }
 414         }
 415         $content .= qq(<a accesskey="8" href="$docroot">ch list[8]</a>);
 416       }else{
 417         # channel list
 418         $content .= &index_page;
 419       }
 420     }else{
 421         # channel conversation
 422         $uri =~ s|^/||;
 423
 424         # RFC 2811:
 425         # Apart from the the requirement that the first character
 426         # being either '&', '#', '+' or '!' (hereafter called "channel
 427         # prefix"). The only restriction on a channel name is that it
 428         # SHALL NOT contain any spaces (' '), a control G (^G or ASCII
 429         # 7), a comma (',' which is used as a list item separator by
 430         # the protocol).  Also, a colon (':') is used as a delimiter
 431         # for the channel mask.  The exact syntax of a channel name is
 432         # defined in "IRC Server Protocol" [IRC-SERVER].
 433         #
 434         # so we use white space as separator character of channel name
 435         # and command argument.
 436
 437         my $channel = uri_unescape($uri);
 438
 439         $content .= '<title>' . $config->web_title . ": $channel</title>";
 440         $content .= '</head>';
 441         $content .= '<body>';
 442
 443         $content .= '<a name="1"></a>';
 444         $content .= '<a accesskey="7" href="#1"></a>';
 445
 446         $content .= sprintf('<form action="%s%s" method="post">',
 447                             $docroot, uri_escape($channel));
 448         $content .= '<input type="text" name="m" size="10">';
 449         $content .= '<input type="submit" accesskey="1" value="OK[1]">';
 450         $content .= qq(<a accesskey="8" href="$docroot">ch list[8]</a><br>);
 451         # $content .= '<input type="submit" accesskey="1" value="&#63920;">';
 452         $content .= '</form>';
 453
 454         my $canon_channel = &canon_name($channel);
 455         if(defined($channel_name{$canon_channel})){
 456             if(defined($channel_buffer{$canon_channel}) &&
 457                length($channel_buffer{$canon_channel})){
 458                 $content .= '<a accesskey="9" href="#2"></a>';
 459                 if($option{recent} ||
 460                    (defined($config->show_newmsgonly) && $message_added)){
 461                   $content .= &render($channel_recent{$canon_channel});
 462                   $content .= sprintf('<a accesskey="5" href="%s%s">more[5]</a>',
 463                                       $docroot, uri_escape($channel));
 464                 } else {
 465                   $content .= &render($channel_buffer{$canon_channel});
 466                 }
 467                 $content .= '<a name="2"></a>';
 468             }else{
 469                 $content .= 'no message here yet';
 470             }
 471         }else{
 472             $content .= 'no such channel';
 473         }
 474
 475         # clear check flags
 476         $message_added = false;
 477
 478         # clear unread counter
 479         $unread_lines{$canon_channel} = 0;
 480
 481         # clear recent messages buffer
 482         $channel_recent{$canon_channel} = '';
 483     }
 484
 485     $content .= '</body></html>';
 486
 487     my $response = HTTP::Response->new(200);
 488     $response->push_header('Content-type', 'text/html; charset=Shift_JIS');
 489     $response->content(Jcode->new($content)->sjis);
 490     $heap->{client}->put($response);
 491     $kernel->yield('shutdown');
 492 }
 493
 494 __END__