keitairc

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