keitairc

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