keitairc

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