keitairc

   1 #!/usr/bin/perl
   2 # keitairc
   3 # $Id: keitairc,v 1.21 2004-07-24 08:54:51 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.21 2004-07-24 08:54:51 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 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                   irc_ctcp_action => \&on_irc_ctcp_action,
  70                   );
  71
  72 # web server component
  73 POE::Component::Server::TCP->new(
  74                                  Alias => 'keitairc',
  75                                  Port => $config->web_port,
  76                                  ClientFilter => 'POE::Filter::HTTPD',
  77                                  ClientInput => \&on_web_request
  78                                  );
  79
  80 $poe_kernel->run();
  81 exit 0;
  82
  83 ################################################################
  84 sub on_irc_start{
  85     my $kernel = $_[KERNEL];
  86     $kernel->post('keitairc' => 'register' => 'all');
  87     $kernel->post('keitairc' => 'connect' => {
  88         Nick => $config->irc_nick,
  89         Username => $config->irc_username,
  90         Ircname => $config->irc_desc,
  91         Server => $config->irc_server,
  92         Port => $config->irc_port,
  93         Password => $config->irc_password
  94     });
  95 }
  96
  97 ################################################################
  98 sub on_irc_join{
  99     my ($kernel, $who, $channel) = @_[KERNEL, ARG0, ARG1];
 100     $who =~ s/!.*//;
 101
 102     # chop off after the gap (bug workaround of madoka)
 103     $channel =~ s/ .*//;
 104
 105     $channel_name{$channel}++;
 106     unless ($who eq $config->irc_nick) {
 107       &add_message($channel, undef, "$who joined");
 108     }
 109 }
 110
 111 ################################################################
 112 sub on_irc_part{
 113     my ($kernel, $who, $channel) = @_[KERNEL, ARG0, ARG1];
 114     $who =~ s/!.*//;
 115
 116     # chop off after the gap (bug workaround of POE::Filter::IRC)
 117     $channel =~ s/ .*//;
 118
 119     if ($who eq $config->irc_nick) {
 120        delete $channel_name{$channel};
 121     } else {
 122        &add_message($channel, undef, "$who leaves");
 123     }
 124 }
 125
 126 ################################################################
 127 sub on_irc_public{
 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 sub on_irc_notice{
 137     my ($kernel, $who, $channel, $msg) = @_[KERNEL, ARG0 .. ARG2];
 138     $who =~ s/!.*//;
 139     $channel = $channel->[0];
 140     $msg = Jcode->new($msg, 'jis')->euc;
 141     &add_message($channel, $who, $msg);
 142 }
 143
 144 ################################################################
 145 sub on_irc_ctcp_action{
 146     my ($kernel, $who, $channel, $msg) = @_[KERNEL, ARG0 .. ARG2];
 147     $who =~ s/!.*//;
 148     $channel = $channel->[0];
 149     $msg = sprintf('* %s %s', $who, Jcode->new($msg, 'jis')->euc);
 150     &add_message($channel, '', $msg);
 151 }
 152
 153 ################################################################
 154 # $msg \e$B$O\e(B EUC \e$B$K$J$C$F$$$k$O$:\e(B
 155 # $channel \e$B$O\e(B jis \e$B$G$-$F$k$>\e(B
 156 sub add_message{
 157     my($channel, $who, $msg) = @_;
 158
 159     my $message;
 160     if(length $who){
 161       $message = sprintf('%s %s> %s', &now, $who, $msg);
 162     }else{
 163       $message = sprintf('%s %s', &now, $msg);
 164     }
 165
 166     my @tmp = split("\n", $channel_buffer{$channel});
 167     push @tmp, $message;
 168
 169     my @tmp2 = split("\n", $channel_recent{$channel});
 170     push @tmp2, $message;
 171
 172     if(@tmp > $config->web_lines){
 173         $channel_buffer{$channel} =
 174                 join("\n", splice(@tmp, -$config->web_lines));
 175     }else{
 176         $channel_buffer{$channel} = join("\n", @tmp);
 177     }
 178
 179     if(@tmp2 > $config->web_lines){
 180         $channel_recent{$channel} =
 181                 join("\n", splice(@tmp2, -$config->web_lines));
 182     }else{
 183         $channel_recent{$channel} = join("\n", @tmp2);
 184     }
 185
 186     $mtime{$channel} = time;
 187
 188     # unread lines
 189     $unread{$channel} = scalar(@tmp2);
 190
 191     if ($unread{$channel} > $config->web_lines) {
 192         $unread{$channel} = $config->web_lines;
 193     }
 194 }
 195
 196 ################################################################
 197 sub now{
 198     my ($sec,$min,$hour) = localtime(time);
 199     sprintf('%02d:%02d', $hour, $min);
 200 }
 201
 202 ################################################################
 203 sub escape{
 204     local($_) = shift;
 205     s/&/&amp;/g;
 206     s/>/&gt;/g;
 207     s/</&lt;/g;
 208     $_;
 209 }
 210
 211 ################################################################
 212 sub label{
 213     my $accesskey = shift;
 214
 215     if($accesskey < 10){
 216         sprintf('%d ', $accesskey);
 217     }else{
 218         '  ';
 219     }
 220 }
 221
 222 ################################################################
 223 sub index_page{
 224     my $buf;
 225     my $accesskey = 1;
 226
 227     for my $channel (sort {
 228         $mtime{$b} <=> $mtime{$a};
 229     }(keys(%channel_name))){
 230
 231         $buf .= &label($accesskey);
 232
 233         if($accesskey < 10){
 234                 $buf .= sprintf('<a accesskey="%1d" href="%s%s">%s</a>',
 235                                 $accesskey,
 236                                 $docroot,
 237                                 uri_escape($channel),
 238                                 &compact_channel_name($channel));
 239         }else{
 240                 $buf .= sprintf('<a href="%s%s">%s</a>',
 241                                 $docroot,
 242                                 uri_escape($channel),
 243                                 &compact_channel_name($channel));
 244         }
 245
 246         $accesskey++;
 247
 248         # \e$BL$FI9T?t\e(B
 249         if($unread{$channel} > 0){
 250                 $buf .= sprintf(' <a href="%s%s.update">%d</a>',
 251                                 $docroot,
 252                                 uri_escape($channel),
 253                                 $unread{$channel});
 254         }
 255         $buf .= '<br>';
 256     }
 257
 258     $buf .= qq(0 <a href="$docroot" accesskey="0">refresh list</a><br>);
 259     $buf .= qq( - keitairc $version);
 260     $buf;
 261 }
 262
 263 ################################################################
 264 # \e$B%A%c%M%kL>>N$rC;$+$/$9$k\e(B
 265 sub compact_channel_name{
 266     local($_) = shift;
 267
 268     # #name:*.jp \e$B$r\e(B %name \e$B$K\e(B
 269     if(s/:\*\.jp$//){
 270         s/^#/%/;
 271     }
 272
 273     # \e$BKvHx$NC1FH$N\e(B @ \e$B$O<h$k\e(B (for multicast.plm)
 274     s/\@$//;
 275
 276     $_;
 277 }
 278
 279 ################################################################
 280 sub render{
 281     local($_);
 282     my @buf;
 283
 284     my @src = (reverse(split("\n", shift)))[0 .. $config->web_lines];
 285
 286     for (@src){
 287         next unless defined;
 288         next unless length;
 289
 290         $_ = &escape($_);
 291
 292         unless(s,\b(https?://[!-;=-\177]+)\b,<a href="$1">$1</a>,g){
 293             unless(s|\b(www\.[!-\177]+)\b|<a href="http://$1">$1</a>|g){
 294                 # phone to
 295                 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){
 296                     s|\b(\w[\w.+=-]+\@[\w.-]+[\w]\.[\w]{2,4})\b|<a href="mailto:$1">$1</a>|g;
 297                 }
 298             }
 299         }
 300
 301         s/\s+$//;
 302         s/\s+/ /g;
 303         push @buf, $_;
 304     }
 305
 306     '<pre>' . join("\n", @buf) . '</pre>';
 307 }
 308
 309 ################################################################
 310 sub on_web_request{
 311     my ($kernel, $heap, $request) = @_[KERNEL, HEAP, ARG0];
 312
 313     # Filter::HTTPD sometimes generates HTTP::Response objects.
 314     # They indicate (and contain the response for) errors that occur
 315     # while parsing the client's HTTP request.  It's easiest to send
 316     # the responses as they are and finish up.
 317     if($request->isa('HTTP::Response')){
 318         $heap->{client}->put($request);
 319         $kernel->yield('shutdown');
 320         return;
 321     }
 322
 323     if(defined($config->web_username)){
 324         unless($request->headers->authorization_basic eq
 325                $config->web_username . ':' . $config->web_password){
 326
 327             my $response = HTTP::Response->new(401);
 328             $response->push_header(WWW_Authenticate =>
 329                                    qq(Basic Realm="keitairc"));
 330             $heap->{client}->put($response);
 331             $kernel->yield('shutdown');
 332             return;
 333         }
 334     }
 335
 336     my $uri = $request->uri;
 337     my $content = '<html><head>';
 338     $content .= '<meta http-equiv="Cache-Control" content="max-age=0" />';
 339
 340     # POST \e$B$5$l$F$-$?$b$N$OH/8@\e(B
 341     if($request->method =~ /POST/i){
 342         my $message = $request->content;
 343         $message =~ s/^m=//;
 344         $message =~ s/\+/ /g;
 345         $message = uri_unescape($message);
 346
 347         if(length($message)){
 348             $uri =~ s|^/||;
 349             my $channel = uri_unescape($uri);
 350             $poe_kernel->post('keitairc',
 351                               'privmsg',
 352                               Jcode->new($channel)->jis,
 353                               Jcode->new($message)->jis);
 354             &add_message($channel, $config->irc_nick,
 355                          Jcode->new($message)->euc);
 356
 357             # set flag for "send message"
 358             $send_chk = 1;
 359         }
 360     }
 361
 362     if($uri eq '/'){
 363         $content .= '<title>' . $config->web_title . '</title>';
 364         $content .= '</head>';
 365         $content .= '<body>';
 366         $content .= &index_page;
 367     }else{
 368         $uri =~ s|^/||;
 369
 370         $update_chk = ($uri =~ /.*.update/);
 371         if ($update_chk eq 1) {
 372                 $uri =~ s/.update//;
 373         }
 374
 375         my $channel = uri_unescape($uri);
 376
 377         $content .= '<title>' . $config->web_title . ": $channel</title>";
 378         $content .= '</head>';
 379         $content .= '<body>';
 380
 381         $content .= '<a name="1"></a>';
 382         $content .= '<a accesskey="7" href="#1"></a>';
 383
 384         $content .= sprintf('<form action="%s%s" method="post">',
 385                             $docroot, uri_escape($channel));
 386         $content .= '<input type="text" name="m" size="10">';
 387         $content .= '<input type="submit" accesskey="1" value="OK[1]">';
 388         $content .= qq(<a accesskey="8" href="$docroot">back[8]</a><br>);
 389         # $content .= '<input type="submit" accesskey="1" value="&#63920;">';
 390         $content .= '</form>';
 391
 392         if(defined($channel_name{$channel})){
 393             if(defined($channel_buffer{$channel}) &&
 394                length($channel_buffer{$channel})){
 395                 $content .= '<a accesskey="9" href="#2"></a>';
 396                 if ((($update_chk eq 1)||((defined $config->show_newmsgonly) && ($send_chk eq 1)))) {
 397                   $content .= &render($channel_recent{$channel});
 398                   $content .= sprintf('<a accesskey="5" href="%s%s">
 399                         ..more[5]</a>', $docroot, uri_escape($channel));
 400                 } else {
 401                   $content .= &render($channel_buffer{$channel});
 402                 }
 403                 $content .= '<a name="2"></a>';
 404             }else{
 405                 $content .= 'no message here yet';
 406             }
 407         }else{
 408             $content .= "no such channel";
 409         }
 410
 411         # clear check flags
 412         $send_chk = 0;
 413
 414         # clear unread counter
 415         $unread{$channel} = 0;
 416
 417         # clear recent messages buffer
 418         $channel_recent{$channel} = '';
 419     }
 420
 421     $content .= '</body></html>';
 422
 423     my $response = HTTP::Response->new(200);
 424     $response->push_header('Content-type', 'text/html; charset=Shift_JIS');
 425     $response->content(Jcode->new($content)->sjis);
 426     $heap->{client}->put($response);
 427     $kernel->yield('shutdown');
 428 }
 429
 430 __END__