keitairc

   1 #!/usr/bin/perl
   2 # keitairc
   3 # $Id: keitairc,v 1.9 2004-03-21 11:03:19 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.9 2004-03-21 11:03:19 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)
  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;
  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 # irc component
  59 POE::Component::IRC->new('keitairc');
  60 POE::Session->new(
  61                   _start => \&on_irc_start,
  62                   irc_join => \&on_irc_join,
  63                   irc_part => \&on_irc_part,
  64                   irc_public => \&on_irc_public,
  65                   irc_notice => \&on_irc_notice,
  66                   );
  67
  68 # web server component
  69 POE::Component::Server::TCP->new(
  70                                  Alias => 'keitairc',
  71                                  Port => $config->web_port,
  72                                  ClientFilter => 'POE::Filter::HTTPD',
  73                                  ClientInput => \&on_web_request
  74                                  );
  75
  76 $poe_kernel->run();
  77 exit 0;
  78
  79 ################################################################
  80 sub on_irc_start{
  81     my $kernel = $_[KERNEL];
  82     $kernel->post('keitairc' => 'register' => 'all');
  83     $kernel->post('keitairc' => 'connect' => {
  84         Nick => $config->irc_nick,
  85         Username => $config->irc_username,
  86         Ircname => $config->irc_desc,
  87         Server => $config->irc_server,
  88         Port => $config->irc_port,
  89         Password => $config->irc_password
  90     });
  91 }
  92
  93 ################################################################
  94 sub on_irc_join{
  95     my ($kernel, $who, $channel) = @_[KERNEL, ARG0, ARG1];
  96     $channel_name{$channel}++;
  97 }
  98
  99 ################################################################
 100 sub on_irc_part{
 101     my ($kernel, $who, $channel) = @_[KERNEL, ARG0, ARG1];
 102
 103     # chop off after the gap (bug workaround of POE::Filter::IRC)
 104     $channel =~ s/ .*//;
 105
 106     delete $channel_name{$channel};
 107 }
 108
 109 ################################################################
 110 sub on_irc_public{
 111     my ($kernel, $who, $channel, $msg) = @_[KERNEL, ARG0 .. ARG2];
 112     $who =~ s/!.*//;
 113     $channel = $channel->[0];
 114     $msg = Jcode->new($msg, 'jis')->euc;
 115     &add_message($channel, $who, $msg);
 116 }
 117
 118 ################################################################
 119 sub on_irc_notice{
 120     my ($kernel, $who, $channel, $msg) = @_[KERNEL, ARG0 .. ARG2];
 121     $who =~ s/!.*//;
 122     $channel = $channel->[0];
 123     $msg = Jcode->new($msg, 'jis')->euc;
 124     &add_message($channel, $who, $msg);
 125 }
 126
 127 ################################################################
 128 # $msg \e$B$O\e(B EUC \e$B$K$J$C$F$$$k$O$:\e(B
 129 # $channel \e$B$O\e(B jis \e$B$G$-$F$k$>\e(B
 130 sub add_message{
 131     my($channel, $who, $msg) = @_;
 132
 133     my @tmp = split("\n", $channel_buffer{$channel});
 134     push @tmp, sprintf('%s %s> %s', &now, $who, $msg);
 135
 136     if(@tmp > $config->web_lines){
 137         $channel_buffer{$channel} = join("\n", splice(@tmp, -$config->web_lines));
 138     }else{
 139         $channel_buffer{$channel} = join("\n", @tmp);
 140     }
 141
 142     $mtime{$channel} = time;
 143     $unread{$channel}++;
 144     if ($unread{$channel} > $config->web_lines) {
 145         $unread{$channel} = $config->web_lines;
 146     }
 147 }
 148
 149 ################################################################
 150 sub now{
 151     my ($sec,$min,$hour) = localtime(time);
 152     sprintf('%02d:%02d', $hour, $min);
 153 }
 154
 155 ################################################################
 156 sub escape{
 157     local($_) = shift;
 158     s/&/&amp;/;
 159     s/>/&gt;/;
 160     s/</&lt;/;
 161     $_;
 162 }
 163
 164 ################################################################
 165 sub label{
 166     my $accesskey = shift;
 167
 168     if($accesskey < 10){
 169         sprintf('%d ', $accesskey);
 170     }else{
 171         '  ';
 172     }
 173 }
 174
 175 ################################################################
 176 sub index_page{
 177     my $buf;
 178     my $accesskey = 1;
 179
 180     for my $channel (sort {
 181         $mtime{$b} <=> $mtime{$a};
 182     }(keys(%channel_name))){
 183
 184         $buf .= &label($accesskey);
 185
 186             if($accesskey < 10){
 187                 $buf .= sprintf('<a accesskey="%1d" href="%s%s">%s</a>',
 188                                 $accesskey,
 189                                 $docroot,
 190                                 uri_escape($channel),
 191                                 &compact_channel_name($channel));
 192             }else{
 193                 $buf .= sprintf('<a href="%s%s">%s</a>',
 194                                 $docroot,
 195                                 uri_escape($channel),
 196                                 &compact_channel_name($channel));
 197             }
 198
 199         $accesskey++;
 200
 201         if($unread{$channel} > 0){
 202             $buf .= sprintf(' (%d)', $unread{$channel});
 203         }
 204
 205         $buf .= '<br>';
 206     }
 207
 208     $buf .= qq(<a href="$docroot" accesskey="0"></a>);
 209     $buf .= qq( - keitairc $version +);
 210
 211     $buf;
 212 }
 213
 214 ################################################################
 215 # \e$B%A%c%M%kL>>N$rC;$+$/$9$k\e(B
 216 sub compact_channel_name{
 217     local($_) = shift;
 218
 219     # #name:*.jp \e$B$r\e(B %name \e$B$K\e(B
 220     if(s/:\*\.jp$//){
 221         s/^#/%/;
 222     }
 223
 224     # \e$BKvHx$NC1FH$N\e(B @ \e$B$O<h$k\e(B (for multicast.plm)
 225     s/\@$//;
 226
 227     $_;
 228 }
 229
 230 ################################################################
 231 sub render{
 232     local($_);
 233     my @buf;
 234
 235     my @src = (reverse(split("\n", shift)))[0 .. $config->web_lines];
 236
 237     for (@src){
 238         next unless defined;
 239         next unless length;
 240
 241         $_ = &escape($_);
 242
 243         unless(s,(http://[!-;=-\177]+),<a href="$1">$1</a>,g){
 244             unless(s|(www\.[!-\177]+)|<A HREF="http://$1">$1</A>|g){
 245                 # phone to
 246                 unless(s|(0\d{1,3}[-(]?\d{2,4}[-)]?\d{4})|<a href="tel:$1">$1</a>|g){
 247                     s|(\w[\w.+=-]+\@[\w.-]+[\w])|<a href="mailto:$1">$1</a>|g;
 248                 }
 249             }
 250         }
 251
 252         s/\s+$//;
 253         s/\s+/ /g;
 254         push @buf, $_;
 255     }
 256
 257     '<pre>' . join("\n", @buf) . '</pre>';
 258 }
 259
 260 ################################################################
 261 sub on_web_request{
 262     my ($kernel, $heap, $request) = @_[KERNEL, HEAP, ARG0];
 263
 264     # Filter::HTTPD sometimes generates HTTP::Response objects.
 265     # They indicate (and contain the response for) errors that occur
 266     # while parsing the client's HTTP request.  It's easiest to send
 267     # the responses as they are and finish up.
 268     if($request->isa('HTTP::Response')){
 269         $heap->{client}->put($request);
 270         $kernel->yield('shutdown');
 271         return;
 272     }
 273
 274     if(defined($config->web_username)){
 275         unless($request->headers->authorization_basic eq
 276                $config->web_username . ':' . $config->web_password){
 277
 278             my $response = HTTP::Response->new(401);
 279             $response->push_header(WWW_Authenticate =>
 280                                    qq(Basic Realm="keitairc"));
 281             $heap->{client}->put($response);
 282             $kernel->yield('shutdown');
 283             return;
 284         }
 285     }
 286
 287     my $uri = $request->uri;
 288     my $content = '<html><head>';
 289
 290     # POST \e$B$5$l$F$-$?$b$N$OH/8@\e(B
 291     if($request->method =~ /POST/i){
 292         my $message = $request->content;
 293         $message =~ s/^m=//;
 294         $message =~ s/\+/ /g;
 295         $message = uri_unescape($message);
 296
 297         if(length($message)){
 298             $uri =~ s|^/||;
 299             my $channel = uri_unescape($uri);
 300             $poe_kernel->post('keitairc',
 301                               'privmsg',
 302                               Jcode->new($channel)->jis,
 303                               Jcode->new($message)->jis);
 304             &add_message($channel, $config->irc_nick,
 305                          Jcode->new($message)->euc);
 306         }
 307     }
 308
 309     if($uri eq '/'){
 310         $content .= '<title>' . $config->web_title . '</title>';
 311         $content .= '</head>';
 312         $content .= '<body>';
 313         $content .= &index_page;
 314     }else{
 315         $uri =~ s|^/||;
 316         my $channel = uri_unescape($uri);
 317
 318         $content .= '<title>' . $config->web_title . ": $channel</title>";
 319         $content .= '<body>';
 320
 321         $content .= '<a name="1"></a>';
 322         $content .= '<a accesskey="7" href="#1"></a>';
 323         $content .= '<a accesskey="8" href="../"></a>';
 324
 325         $content .= sprintf('<form action="%s%s" method="post">',
 326                             $docroot, $uri);
 327         $content .= '<input type="text" name="m" size="10">';
 328         $content .= '<input type="submit" accesskey="1" value="OK">';
 329         # $content .= '<input type="submit" accesskey="1" value="&#63920;">';
 330         $content .= '</form>';
 331         $content .= '<a href="../">..back (push 8)</a><BR>';
 332
 333         if(defined($channel_name{$channel})){
 334             if(defined($channel_buffer{$channel}) &&
 335                length($channel_buffer{$channel})){
 336                 $content .= qq(<a accesskey="8" href="$docroot"></a>);
 337                 $content .= '<a accesskey="9" href="#2"></a>';
 338                 $content .= &render($channel_buffer{$channel});
 339                 $content .= '<a name="2"></a>';
 340             }else{
 341                 $content .= 'no message here yet';
 342             }
 343         }else{
 344             $content .= "no such channel";
 345         }
 346
 347         $unread{$channel} = 0;
 348     }
 349
 350     $content .= '</body></html>';
 351
 352     my $response = HTTP::Response->new(200);
 353     $response->push_header('Content-type', 'text/html; charset=Shift_JIS');
 354     $response->content(Jcode->new($content)->sjis);
 355     $heap->{client}->put($response);
 356     $kernel->yield('shutdown');
 357 }
 358
 359 __END__