keitairc

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