keitairc

   1 #!/usr/bin/perl
   2 # keitairc
   3 # $Id: keitairc,v 1.3 2004-03-21 11:01:33 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 use strict;
  12 use Jcode;
  13 use POE;
  14 use POE::Component::Server::TCP;
  15 use POE::Component::IRC;
  16 use POE::Filter::HTTPD;
  17 use URI::Escape;
  18 use HTTP::Response;
  19 use AppConfig qw(:argcount);
  20
  21 my $config = AppConfig->new(
  22                             {
  23                                 CASE => 1,
  24                                 GLOBAL => {
  25                                     ARGCOUNT => ARGCOUNT_ONE,
  26                                 }
  27                             },
  28                             qw(irc_nick irc_username irc_desc
  29                                irc_server irc_port irc_password
  30                                web_port web_title web_lines
  31                                web_username web_password)
  32                             );
  33
  34 unless($config->file($ENV{'HOME'} . '/.keitairc')){
  35     $config->file('/etc/keitairc');
  36 }
  37 $config->args;
  38
  39 my (%channels, %buffer, %atime, %mtime);
  40
  41 # irc component
  42 POE::Component::IRC->new('keitairc');
  43 POE::Session->new(
  44                   _start => \&on_irc_start,
  45                   irc_join => \&on_irc_join,
  46                   irc_part => \&on_irc_part,
  47                   irc_public => \&on_irc_public,
  48                   irc_notice => \&on_irc_notice,
  49                   );
  50
  51 # web server component
  52 POE::Component::Server::TCP->new(
  53                                  Alias => 'keitairc',
  54                                  Port => $config->web_port,
  55                                  ClientFilter => 'POE::Filter::HTTPD',
  56                                  ClientInput => \&on_web_request
  57                                  );
  58
  59 $poe_kernel->run();
  60 exit 0;
  61
  62 ################################################################
  63 sub on_irc_start{
  64     my $kernel = $_[KERNEL];
  65     $kernel->post('keitairc' => 'register' => 'all');
  66     $kernel->post('keitairc' => 'connect' => {
  67         Nick => $config->irc_nick,
  68         Username => $config->irc_username,
  69         Ircname => $config->irc_desc,
  70         Server => $config->irc_server,
  71         Port => $config->irc_port,
  72         Password => $config->irc_password
  73     });
  74 }
  75
  76 ################################################################
  77 sub on_irc_join{
  78     my ($kernel, $who, $channel) = @_[KERNEL, ARG0, ARG1];
  79     $channel = Jcode->new($channel)->euc;
  80     $channels{$channel}++;
  81 }
  82
  83 ################################################################
  84 sub on_irc_part{
  85     my ($kernel, $who, $channel) = @_[KERNEL, ARG0, ARG1];
  86     $channel = Jcode->new($channel->[0])->euc;
  87     delete $channels{$channel};
  88 }
  89
  90 ################################################################
  91 sub on_irc_public{
  92     my ($kernel, $who, $channel, $msg) = @_[KERNEL, ARG0 .. ARG2];
  93     $who =~ s/!.*//;
  94     $channel = $channel->[0];
  95     $msg = Jcode->new($msg)->euc;
  96     &add_message($channel, $who, $msg);
  97 }
  98
  99 ################################################################
 100 sub on_irc_notice{
 101     my ($kernel, $who, $channel, $msg) = @_[KERNEL, ARG0 .. ARG2];
 102     $who =~ s/!.*//;
 103     $channel = $channel->[0];
 104     $msg = Jcode->new($msg)->euc;
 105     &add_message($channel, $who, $msg);
 106 }
 107
 108 ################################################################
 109 # $msg \e$B$O\e(B EUC \e$B$K$J$C$F$$$k$O$:\e(B
 110 # $channel \e$B$O\e(B jis \e$B$G$-$F$k$>\e(B
 111 sub add_message{
 112     my($channel, $who, $msg) = @_;
 113
 114     $channel = Jcode->new($channel)->euc;
 115
 116     my @tmp = split("\n", $buffer{$channel});
 117     push @tmp, sprintf('%s %s> %s', &now, $who, $msg);
 118
 119     if(@tmp > $config->web_lines){
 120         $buffer{$channel} = join("\n", splice(@tmp, -$config->web_lines));
 121     }else{
 122         $buffer{$channel} = join("\n", @tmp);
 123     }
 124
 125     $mtime{$channel} = time;
 126 }
 127
 128 ################################################################
 129 sub now{
 130     my ($sec,$min,$hour) = localtime(time);
 131     sprintf('%02d:%02d', $hour, $min);
 132 }
 133
 134 ################################################################
 135 sub escape{
 136     local($_) = shift;
 137     s/&/&amp;/;
 138     s/>/&gt;/;
 139     s/</&lt;/;
 140     $_;
 141 }
 142
 143 ################################################################
 144 sub index_page{
 145     my $buf;
 146     my $accesskey = 1;
 147
 148     for my $channel (sort(keys(%channels))){
 149
 150         if($accesskey < 10){
 151             $buf .= sprintf('&#%d;', 63878 + $accesskey);
 152         }else{
 153             $buf .= '  ';
 154         }
 155
 156         unless(defined($buffer{$channel})){
 157             $buf .= &compact_channel_name($channel);
 158         }else{
 159             if($accesskey < 10){
 160                 $buf .= sprintf('<a accesskey="%1d" href="/%s">%s</a>',
 161                                 $accesskey,
 162                                 uri_escape($channel),
 163                                 &compact_channel_name($channel));
 164             }else{
 165                 $buf .= sprintf('  <a href="/%s">%s</a>',
 166                                 uri_escape($channel),
 167                                 &compact_channel_name($channel));
 168             }
 169         }
 170
 171         $accesskey++;
 172
 173         if($atime{$channel} < $mtime{$channel}){
 174             $buf .= '*';
 175         }
 176
 177         $buf .= '<br>';
 178     }
 179
 180     $buf .= '<a href="/" accesskey="0">';
 181
 182     $buf;
 183 }
 184
 185 ################################################################
 186 sub compact_channel_name{
 187     local($_) = shift;
 188     if(s/:\*\.jp$//){
 189         s/^#/%/;
 190     }
 191     s/\@$//;
 192     $_;
 193 }
 194
 195 ################################################################
 196 sub render{
 197     local($_);
 198     my @buf;
 199
 200     my @src = (reverse(split("\n", shift)))[0 .. $config->web_lines];
 201
 202     for (@src){
 203         next unless defined;
 204         next unless length;
 205
 206         $_ = &escape($_);
 207
 208         unless(s,(http://[!-;=-\177]+),<a href="$1">$1</a>,g){
 209             unless(s|(www\.[!-\177]+)|<A HREF="http://$1">$1</A>|g){
 210                 # phone to
 211                 unless(s|(0\d{1,3}[-(]?\d{2,4}[-)]?\d{4})|<a href="tel:$1">$1</a>|g){
 212                     s|(\w[\w.+=-]+\@[\w.-]+[\w])|<a href="mailto:$1">$1</a>|g;
 213                 }
 214             }
 215         }
 216
 217         s/\s+$//;
 218         s/\s+/ /g;
 219         push @buf, $_;
 220     }
 221
 222     '<pre>' . join("\n", @buf) . '</pre>';
 223 }
 224
 225 ################################################################
 226 sub on_web_request{
 227     my ($kernel, $heap, $request) = @_[KERNEL, HEAP, ARG0];
 228
 229     # Filter::HTTPD sometimes generates HTTP::Response objects.
 230     # They indicate (and contain the response for) errors that occur
 231     # while parsing the client's HTTP request.  It's easiest to send
 232     # the responses as they are and finish up.
 233     if($request->isa('HTTP::Response')){
 234         $heap->{client}->put($request);
 235         $kernel->yield('shutdown');
 236         return;
 237     }
 238
 239     if(defined($config->web_username)){
 240         unless($request->headers->authorization_basic eq
 241                $config->web_username . ':' . $config->web_password){
 242
 243             my $response = HTTP::Response->new(401);
 244             $response->push_header(WWW_Authenticate =>
 245                                    qq(Basic Realm="keitairc"));
 246             $heap->{client}->put($response);
 247             $kernel->yield('shutdown');
 248             return;
 249         }
 250     }
 251
 252     my $uri = $request->uri;
 253     my $content = '<html><head>';
 254
 255     # POST \e$B$5$l$F$-$?$b$N$OH/8@\e(B
 256     if($request->method =~ /POST/i){
 257         my $message = $request->content;
 258         $message =~ s/^m=//;
 259         $message =~ s/\+/ /g;
 260         $message = uri_unescape($message);
 261
 262         if(length($message)){
 263             $uri =~ s|^/||;
 264             my $channel = uri_unescape($uri);
 265             $poe_kernel->post('keitairc',
 266                               'privmsg',
 267                               Jcode->new($channel)->jis,
 268                               Jcode->new($message)->jis);
 269             &add_message($channel, $config->irc_nick, $message);
 270         }
 271     }
 272
 273     if($uri eq '/'){
 274         $content .= '<title>' . $config->web_title . '</title>';
 275         $content .= '<body>';
 276         $content .= &index_page;
 277     }else{
 278         $uri =~ s|^/||;
 279         my $channel = uri_unescape($uri);
 280
 281         $content .= '<title>' . $config->web_title . ': $channel</title>';
 282         $content .= '<body>';
 283
 284         $content .= '<a name="1"></a>';
 285         $content .= '<a accesskey="7" href="#1"></a>';
 286
 287         $content .= sprintf('<form action="/%s" method="post">', $uri);
 288         $content .= '<input type="text" name="m" size="10">';
 289         $content .= '<input type="submit" accesskey="1" value="&#63920;">';
 290         $content .= '</form>';
 291
 292         if(defined($channels{$channel})){
 293             if(defined($buffer{$channel}) &&
 294                length($buffer{$channel})){
 295                 $content .= '<a accesskey="8" href="/"></a>';
 296                 $content .= '<a accesskey="9" href="#2"></a>';
 297                 $content .= &render($buffer{$channel});
 298                 $content .= '<a name="2"></a>';
 299             }else{
 300                 $content .= 'no message here yet';
 301             }
 302         }else{
 303             $content .= "no such channel";
 304         }
 305
 306         $atime{$channel} = time;
 307     }
 308
 309     $content .= '</body></html>';
 310
 311     my $response = HTTP::Response->new(200);
 312     $response->push_header('Content-type', 'text/html; charset=Shift_JIS');
 313     $response->content(Jcode->new($content)->sjis);
 314     $heap->{client}->put($response);
 315     $kernel->yield('shutdown');
 316 }
 317
 318 __END__