#!/usr/bin/env perl # keitairc # $Id: keitairc,v 1.29 2004/09/16 13:44:10 morimoto Exp $ # # Copyright (c) 2003 Jun Morimoto # This program is covered by the GNU General Public License 2 # # Depends: libpoe-component-irc-perl, # liburi-perl, libwww-perl, libappconfig-perl, # libunicode-japanese-perl | libjcode-pm-perl # Copyright of Changes (c) 2003 IKARASHI Yoshinori # # $Id$ # # Cookie Version # Copyright of Changes (c) 2003 HICHISATO Jun # # $Id$ # # V1.6 Based Merge Version (yoosee + Cookie + yukinon) # Copyright of Changes (c) 2003 HIIRAGI Yukio # # $Id$ # # utf8 uri + use Unicode::Japanese # Copyright of Changes (c) 2004 Topia # # $Id$ # my $rcsid = q$Id: keitairc,v 1.29 2004/09/16 13:44:10 morimoto Exp $; my ($version) = $rcsid =~ m#,v ([0-9.]+)#; # yukinon version $version .= "+y9"; $version .= "+t7"; use strict; use POE; use POE::Component::Server::TCP; use POE::Filter::HTTPD; use POE::Component::IRC; use URI::Escape; use HTTP::Response; use AppConfig qw(:argcount); use constant true => 1; use constant false => 0; use constant cookie_ttl => 86400*3; # 3 days require_charset_converter();undef &require_charset_converter; my $config = AppConfig->new( { CASE => 1, GLOBAL => { ARGCOUNT => ARGCOUNT_ONE, } }, qw(irc_nick irc_username irc_desc irc_server irc_port irc_password au_subscriber_id use_cookie web_port web_title web_lines web_root web_username web_password show_newmsgonly web_input_encoding uri_prefix buf_lines net_sep) ); $config->file('/etc/keitairc') if ( -e '/etc/keitairc'); $config->file($ENV{'HOME'} . '/.keitairc'); $config->args; my $docroot = '/'; if (defined $config->web_root) { $docroot = $config->web_root; } my $buf_lines = $config->buf_lines; if (!defined $buf_lines) { $buf_lines = $config->web_lines; } # join しているチャネルの名称を記録するハッシュ my %channel_name; # join しているチャネルの名称を記録するハッシュ my %topic; # チャネルの会話内容を記録するハッシュ my (%channel_buffer, %channel_recent); # 各チャネルの最新発言時刻 my (%mtime); # unread lines my %unread; # chk my ($message_added); # チャンネルユーザーを記録するハッシュ my %users_list; my $users_list_work = ''; # Console my $console = "*Console*"; my $private = "*Private*"; # irc component POE::Component::IRC->new('keitairc'); POE::Session->new( _start => \&on_irc_start, irc_join => \&on_irc_join, irc_part => \&on_irc_part, irc_public => \&on_irc_public, irc_notice => \&on_irc_notice, irc_topic => \&on_irc_topic, irc_332 => \&on_irc_topicraw, irc_ctcp_action => \&on_irc_ctcp_action, irc_quit => \&on_irc_quit, irc_nick => \&on_irc_nick, irc_msg => \&on_irc_msg, irc_353 => \&on_irc_rpl_namreply, irc_366 => \&on_irc_rpl_endofnames, irc_disconnected => \&on_irc_disconnected ); # web server component POE::Component::Server::TCP->new( Alias => 'keitairc', Port => $config->web_port, ClientFilter => 'POE::Filter::HTTPD', ClientInput => \&on_web_request ); $poe_kernel->run(); exit 0; ################################################################ sub on_irc_start{ my $kernel = $_[KERNEL]; $kernel->post('keitairc' => 'register' => 'all'); $kernel->post('keitairc' => 'connect' => { Nick => $config->irc_nick, Username => $config->irc_username, Ircname => $config->irc_desc, Server => $config->irc_server, Port => $config->irc_port, Password => $config->irc_password }); $channel_name{$console}++; $channel_name{$private}++; } ################################################################ sub on_irc_join{ my ($kernel, $who, $channel) = @_[KERNEL, ARG0, ARG1]; $channel = unification_channel_name($channel); $who =~ s/!.*//; $channel_name{$channel}++; &add_users_list($channel, $who); unless ($who eq $config->irc_nick) { my $msg = sprintf('+ %s to %s', $who, &compact_channel_name($channel)); $msg = Jcode->new($msg, 'jis')->euc; &add_message($console, undef, $msg); } } ################################################################ sub on_irc_part{ my ($kernel, $who, $channel) = @_[KERNEL, ARG0, ARG1]; $channel = unification_channel_name($channel); $who =~ s/!.*//; # chop off after the gap (bug workaround of POE::Filter::IRC) $channel =~ s/ .*//; if ($who eq $config->irc_nick) { delete $channel_name{$channel}; delete $unread{$channel}; delete $mtime{$channel}; delete $topic{$channel}; delete $users_list{$channel}; delete $channel_buffer{$channel}; delete $channel_recent{$channel}; } else { &remove_users_list($channel, $who); my $msg = sprintf('- %s from %s', $who, &compact_channel_name($channel)); $msg = Jcode->new($msg, 'jis')->euc; &add_message($console, undef, $msg); } } ################################################################ sub on_irc_quit{ my ($kernel, $who, $msg) = @_[KERNEL, ARG0, ARG1]; $who =~ s/!.*//; for my $channel (sort keys %channel_name) { &remove_users_list($channel, $who); } $msg = Jcode->new($msg, 'jis')->euc; &add_message($console, undef, "! $who ($msg)"); } ################################################################ sub on_irc_public{ my ($kernel, $who, $channel, $msg) = @_[KERNEL, ARG0 .. ARG2]; $who =~ s/!.*//; $channel = $channel->[0]; $msg = Jcode->new($msg, 'jis')->euc; &add_message($channel, "$who>", $msg); } ################################################################ sub on_irc_notice{ my ($kernel, $who, $channel, $msg) = @_[KERNEL, ARG0 .. ARG2]; $who =~ s/!.*//; $channel = $channel->[0]; $msg = Jcode->new($msg, 'jis')->euc; &add_message($channel, "$who)", $msg); } ################################################################ sub on_irc_topic{ my ($kernel, $who, $channel, $topic) = @_[KERNEL, ARG0 .. ARG2]; $who =~ s/!.*//; $topic = Jcode->new($topic, 'jis')->euc; &add_message($channel, undef, "$who set topic: $topic"); add_topic($channel, $topic); } ################################################################ sub on_irc_topicraw{ my ($kernel, $raw) = @_[KERNEL, ARG1]; my ($channel, $topic) = split(/ :/, $raw, 2); add_topic($channel, $topic); } ################################################################ sub on_irc_ctcp_action{ my ($kernel, $who, $channel, $msg) = @_[KERNEL, ARG0 .. ARG2]; $who =~ s/!.*//; $channel = $channel->[0]; $msg = sprintf('* %s %s', $who, Jcode->new($msg, 'jis')->euc); &add_message($channel, '', $msg); } ################################################################ sub on_irc_nick{ my ($kernel, $who, $nick) = @_[KERNEL, ARG0, ARG1]; $who =~ s/!.*//; $nick =~ s/!.*//; if ($who eq $config->irc_nick) { $config->irc_nick($nick); } for my $channel (sort keys %channel_name) { #$users_list{$channel} =~ s/\b$who\b/$nick/g &rename_users_list($channel, $who, $nick); } &add_message($console, undef, "$who -> $nick"); } ################################################################ sub on_irc_msg{ my ($kernel, $who, $channel, $msg) = @_[KERNEL, ARG0 .. ARG2]; $who =~ s/!.*//; $channel = $channel->[0]; $msg = Jcode->new($msg, 'jis')->euc; &add_message($channel, "$who>", $msg); } ################################################################ sub on_irc_rpl_namreply{ my ($kernel, $raw) = @_[KERNEL, ARG1]; my ($channel, $names) = split(/ :/, $raw, 2); $users_list_work .= ' ' unless $users_list_work =~ / $/; $users_list_work .= $names; } ################################################################ sub on_irc_rpl_endofnames{ my ($kernel, $raw) = @_[KERNEL, ARG1]; my ($channel, $names) = split(/ :/, $raw, 2); $channel = unification_channel_name($channel); $users_list_work =~ s/(?new($config->web_title, 'jis')->euc; for my $channel (sort keys %channel_name) { &add_message($channel, undef, "Disconnected Server : $server"); } } ################################################################ # $msg は EUC になっているはず # $channel は jis できてるぞ sub add_message{ my($channel, $who, $msg) = @_; my $bChannel; $bChannel = 0; for my $clist (keys(%channel_name)) { my $dst = lc($clist); my $src = lc($channel); if ($dst eq $src) { $channel = $clist; $bChannel = 1; last; } } if (!$bChannel) { $channel = $private; } $channel = unification_channel_name($channel); # remove color change code $msg =~ s/\x03(\d\d(,\d\d)?)?//g; my $message; if (length $who) { $message = sprintf('%s %s %s', &now, $who, $msg); } else { $message = sprintf('%s %s', &now, $msg); } my @tmp = split("\n", $channel_buffer{$channel}); push @tmp, $message; my @tmp2 = split("\n", $channel_recent{$channel}); push @tmp2, $message; # unread lines $unread{$channel} = scalar(@tmp2); if ($unread{$channel} > $buf_lines) { $unread{$channel} = $buf_lines; } if (@tmp > $buf_lines) { $channel_buffer{$channel} = join("\n", splice(@tmp, -$buf_lines)); } else { $channel_buffer{$channel} = join("\n", @tmp); } if (@tmp2 > $buf_lines) { $channel_recent{$channel} = join("\n", splice(@tmp2, -$buf_lines)); } else { $channel_recent{$channel} = join("\n", @tmp2); } if ($channel eq $console) { $mtime{$channel} = 0; } else { $mtime{$channel} = time; } } ################################################################ sub add_topic{ my($channel, $topic) = @_; $channel = unification_channel_name($channel); $topic{$channel} = $topic; } ################################################################ sub now{ my ($sec,$min,$hour) = localtime(time); sprintf('%02d:%02d', $hour, $min); } ################################################################ sub escape{ local($_) = shift; s/&/&/g; s/>/>/g; s/ $mtime{$a}; }(keys(%channel_name))) { $buf .= &label($accesskey); if ($accesskey < 10) { $buf .= sprintf('%s', $accesskey, $docroot, &channel_to_uri($channel), Jcode->new(&compact_channel_name($channel), 'jis')->euc); } else { $buf .= sprintf('%s', $docroot, &channel_to_uri($channel), Jcode->new(&compact_channel_name($channel), 'jis')->euc); } $accesskey++; # 未読行数 if ($unread{$channel} > 0) { $buf .= sprintf(' %d', $docroot, &channel_to_uri($channel), $unread{$channel}); } $buf .= '
'; } $buf .= qq(0 refresh
); $buf .= qq(* recent
); if (%topic) { $buf .= qq(# topics
); } $buf .= qq( - keitairc $version); $buf; } ################################################################# sub index_recent { my $mobile = shift; my $buf; $buf = ''; for my $channel (sort { $mtime{$b} <=> $mtime{$a}; }(keys(%channel_name))) { if ($unread{$channel} > 0) { $buf .= '

'; $buf .= sprintf('%s
', $docroot, &channel_to_uri($channel), Jcode->new(&compact_channel_name($channel), 'jis')->euc); $buf .= '' if ($mobile); $buf .= &render($channel_recent{$channel}, false); $buf .= '' if ($mobile); $buf .= '

'; } # clear unread counter $unread{$channel} = 0; # clear recent messages buffer $channel_recent{$channel} = ''; } $buf .= qq(0 refresh
); $buf .= qq(# topics
); $buf .= qq(back to list[8]
); return $buf; } ################################################################# sub channel_topic { my $channel = shift; my $mobile = shift; my $buf; $buf = ''; $buf .= '

'; $buf .= sprintf('%s
', $docroot, &channel_to_uri($channel), Jcode->new(&compact_channel_name($channel), 'jis')->euc); $buf .= '' if ($mobile); $buf .= &escape(Jcode->new($topic{$channel}, 'jis')->euc); $buf .= '
'; for my $user (sort split(' ', $users_list{$channel})) { $buf .= $user; $buf .= '
'; } $buf .= '
' if ($mobile); $buf .= '

'; } ################################################################# sub index_topic { my $mobile = shift; my $buf; $buf = ''; for my $channel (sort keys %channel_name) { $buf .= channel_topic($channel, $mobile); } $buf .= qq(0 refresh
); $buf .= qq(* recent
); $buf .= qq(back to list[8]
); return $buf; } ################################################################# sub index_users{ my $mobile = shift; my $buf; for my $channel (sort keys %users_list) { $buf .= '

'; $buf .= sprintf('%s
', $docroot, &channel_to_uri($channel), Jcode->new(&compact_channel_name($channel), 'jis')->euc); $buf .= '' if ($mobile); for my $user (sort split(' ', $users_list{$channel})) { $buf .= $user; $buf .= '
'; } $buf .= '

'; } return $buf; } ################################################################# sub recent_all_messages{ my $current_channel = shift; my $recent_n = shift; $recent_n = 10 unless $recent_n; my $buf = ''; my @tmp = (); for my $channel (keys %channel_name) { next if ( $channel eq $current_channel ); my $link = sprintf('%s', $docroot, &channel_to_uri($channel), Jcode->new(compact_channel_name($channel), 'jis')->euc); # for my $message ( split("\n", $channel_buffer{$channel}) ) { for my $message ( split("\n", $channel_recent{$channel}) ) { push (@tmp, &escape($message) . " ($link)
\n" ); } } my $current_n = 0; for my $message (sort {$b cmp $a;} @tmp) { $buf .= $message; $current_n++; last if $current_n > $recent_n; } return $buf; } ################################################################ # チャネル名称を短かくする sub compact_channel_name{ local($_) = shift; if (defined $config->net_sep) { my $suf = quotemeta($config->net_sep); s/$suf[^$suf]*?($|:)/$1/o; } # #name:*.jp を %name に if (s/:\*\.jp$//) { s/^#/%/; } # 末尾の単独の @ は取る (for multicast.plm) s/\@$//; $_; } ################################################################ sub render{ my($message, $reverse, $page) = @_; my @buf; # my @src = (reverse(split("\n", shift)))[0 .. $config->web_lines]; my @src = (reverse(split("\n", $message)))[$page * $config->web_lines .. ($page+1) * $config->web_lines-1];; @src = reverse(@src) unless $reverse; my $uri_prefix = defined $config->uri_prefix ? $config->uri_prefix : ''; for (@src) { next unless defined; next unless length; $_ = &escape($_); unless (s,\b(https?://[!-;=?-~]+\b/*),$1,g) { unless (s|\b(www\.[!-;=?-~]+\b/*)|$1|g) { # phone to unless (s|\b(0\d{1,3})([-(]?)(\d{2,4})([-)]?)(\d{4})\b|$1$2$3$4$5|g) { s|\b(\w[\w.+=-]+\@[\w.-]+[\w]\.[\w]{2,4})\b|$1|g; } } } s/\s+$//; s/\s+/ /g; $_ .= '
'; push @buf, $_; } # '
' . join("\n", @buf) . '
'; join("\n", @buf); } ################################################################ sub on_web_request{ my ($kernel, $heap, $request) = @_[KERNEL, HEAP, ARG0]; # Filter::HTTPD sometimes generates HTTP::Response objects. # They indicate (and contain the response for) errors that occur # while parsing the client's HTTP request. It's easiest to send # the responses as they are and finish up. if ($request->isa('HTTP::Response')) { $heap->{client}->put($request); $kernel->yield('shutdown'); return; } my $mobile; $mobile = 0; if ($request->user_agent =~ /(DoCoMo|UP\.Browser|J-PHONE)/) { $mobile = 1; } if ($request->user_agent =~ /DDIPOCKET/) { $mobile = 2; } # cookie my $cookie_authorized; if ($config->use_cookie) { my %cookie; for (split(/; */, $request->header('Cookie'))) { my ($name, $value) = split(/=/); $value =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack('C', hex($1))/eg; $cookie{$name} = $value; } if ($cookie{username} eq $config->web_username && $cookie{passwd} eq $config->web_password) { $cookie_authorized = true; } } # authorization unless($cookie_authorized){ unless(defined($config->au_subscriber_id) && $request->header('x-up-subno') eq $config->au_subscriber_id){ if (defined($config->web_username)) { unless($request->headers->authorization_basic eq $config->web_username . ':' . $config->web_password){ my $response = HTTP::Response->new(401); $response->push_header(WWW_Authenticate => qq(Basic realm="keitairc")); $heap->{client}->put($response); $kernel->yield('shutdown'); return; } } } } my $uri = $request->uri; my $content = ''; $content .= ''; # $content .= ''; $content .= ''; # store and remove attached options from uri my %option; while ($uri =~ s/,(.+?)(=.*)?$//) { if (defined $2) { $option{$1} = $2; $option{$1} =~ s/^=//; } else { $option{$1} = $1; } } $uri =~ s|^/||; # POST されてきたものは発言 if ($request->method =~ /POST/i) { my $message = $request->content; $message =~ s/^m=//; $message =~ s/\+/ /g; $message = uri_unescape($message); if (length($message)) { my $channel = &uri_to_channel($uri); if ($message =~ s|^/||) { my ($params, $trailing) = split(/ :/, $message, 2); my @postcmd = split(/ /, $params); push @postcmd, $trailing if defined $trailing; $poe_kernel->post('keitairc', map { Jcode->new($_, $config->web_input_encoding)->jis } @postcmd); } else { $poe_kernel->post('keitairc', 'privmsg', Jcode->new($channel, $config->web_input_encoding)->jis, Jcode->new($message, $config->web_input_encoding)->jis); &add_message($channel, $config->irc_nick . '>', Jcode->new($message, $config->web_input_encoding)->euc); $message_added = true; } } } my $page = $option{p} || 0; if ($uri eq '') { $content .= '' . $config->web_title . ''; $content .= ''; $content .= ''; if ($option{recent}) { $content .= &index_recent($mobile); } elsif ($option{topics}) { $content .= &index_topic($mobile); } elsif ($option{users}) { $content .= &index_users($mobile); } else { $content .= &index_page; } } else { # RFC 2811: # Apart from the the requirement that the first character # being either '&', '#', '+' or '!' (hereafter called "channel # prefix"). The only restriction on a channel name is that it # SHALL NOT contain any spaces (' '), a control G (^G or ASCII # 7), a comma (',' which is used as a list item separator by # the protocol). Also, a colon (':') is used as a delimiter # for the channel mask. The exact syntax of a channel name is # defined in "IRC Server Protocol" [IRC-SERVER]. # # so we use white space as separator character of channel name # and command argument. my $channel = uri_to_channel($uri); $content .= '' . $config->web_title . ": " . Jcode->new($channel, 'jis')->euc . ""; $content .= ''; $content .= ''; if ($option{topic}) { if (defined($channel_name{$channel})) { $content .= channel_topic($channel, $mobile); $content .= sprintf('back[5],', "$docroot", &channel_to_uri($channel)); $content .= qq(list[8]); } else { $content .= "no such channel"; } } else { $content .= ''; $content .= ''; $content .= sprintf('
', $docroot, &channel_to_uri($channel)); my @tmp = split("\n", $channel_buffer{$channel}); my ($goback, $goforward) = ('', ''); my $channel_uri = channel_to_uri($channel); if (0 < $page) { my $pp = $page - 1; $goback .= qq([4]<=); } if (($page+1) * $config->web_lines < @tmp) { my $pp = $page + 1; $goforward .= qq(=>[6]); } if ($mobile) { $content .= sprintf('' , ( $mobile == 1 ? 22 : 15 )); $content .= '
'; if ($goback ne '' or $goforward ne '') { $content .= ' '. $goback . '('.$page.')'. $goforward . ' '; } $content .= qq(Ch[8]); } else { $content .= ''; $content .= '
'; if ($goback ne '' or $goforward ne '') { $content .= ' '. $goback . '('.$page.')'. $goforward . ' '; } $content .= qq(list[8]); } $content .= sprintf(',topic', $docroot, &channel_to_uri($channel)); $content .= '
'; $content .= '' if ($mobile); if (defined($channel_name{$channel})) { if (defined($channel_buffer{$channel}) && length($channel_buffer{$channel})) { $content .= ''; if ($option{recent} || (defined($config->show_newmsgonly) && $message_added)) { $content .= &render($channel_recent{$channel}, true, $page); $content .= sprintf('...more[5]', $docroot, &channel_to_uri($channel)); } else { $content .= &render($channel_buffer{$channel}, true, $page); } $content .= ''; } else { $content .= 'no message here yet'; } } else { $content .= "no such channel"; } # add recent messages in all channels if (!defined $option{update}) { $content .= '
'; $content .= recent_all_messages($channel, 10); } # clear check flags $message_added = false; # clear unread counter $unread{$channel} = 0; # clear recent messages buffer $channel_recent{$channel} = ''; # mobile mode end $content .= '
' if ($mobile); } # add channel list link $content .= '
'; $content .= qq(* recent
); $content .= qq(# topics
); $content .= qq(Channel List
); } $content .= ''; my $response = HTTP::Response->new(200); if ($config->use_cookie) { my ($sec, $min, $hour, $mday, $mon, $year, $wday) = localtime(time + cookie_ttl); my $expiration = sprintf('%.3s, %.2d-%.3s-%.4s %.2d:%.2d:%.2d', qw(Sun Mon Tue Wed Thu Fri Sat)[$wday], $mday, qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)[$mon], $year + 1900, $hour, $min, $sec); $response->push_header('Set-Cookie', sprintf("username=%s; expires=%s; \n", $config->web_username, $expiration)); $response->push_header('Set-Cookie', sprintf("passwd=%s; expires=%s; \n", $config->web_password, $expiration)); } $response->push_header('Content-type', 'text/html; charset=Shift_JIS'); $response->content(Jcode->new($content, 'euc')->sjis); $heap->{client}->put($response); $kernel->yield('shutdown'); } sub uri_to_channel { my ($str) = shift; return Jcode->new(uri_unescape($str), 'utf8')->jis; } sub channel_to_uri { my ($str) = shift; $str = uri_escape(Jcode->new($str, 'jis')->utf8); } sub unification_channel_name { my ($channel) = shift; for my $clist (keys(%channel_name)) { my $dst = lc($clist); my $src = lc($channel); if ($dst eq $src) { $channel = $clist; last; } } return $channel; } sub add_users_list { my ($channel, $who) = @_; $channel = unification_channel_name($channel); my @org = split(" ", $users_list{$channel}); $org[$#org + 1] = $who; $users_list{$channel} = join(" ", @org); } sub remove_users_list { my ($channel, $who) = @_; $channel = unification_channel_name($channel); my @org = split(" ", $users_list{$channel}); my @new = (); for (my $i = 0; $i <= $#org; $i++) { my $name = $org[$i]; if ($name ne $who) { push(@new, $org[$i]); } } $users_list{$channel} = join(" ", @new); } sub rename_users_list { my ($channel, $who, $nick) = @_; $channel = unification_channel_name($channel); my @org = split(" ", $users_list{$channel}); for (my $i = 0; $i < $#org; $i++) { my $name = $org[$i]; if ($name eq $who) { $org[$i] = $nick; } } $users_list{$channel} = join(" ", @org); } sub require_charset_converter { if (eval('use Unicode::Japanese;')) { eval <<'END_OF_JCODE_COMPAT'; # Jcode compat package Jcode; use Unicode::Japanese; our $AUTOLOAD; sub new { my ($class, $str, $input_code) = @_; $input_code = "auto" if !defined $input_code; my $this = { unijp => Unicode::Japanese->new(), }; bless $this, $class; if ($input_code !~ /,/) { $this->set($str, $input_code); } else { my @encodings = split(/\s*,\s*/, $input_code); my $auto_charset = $this->getcode($str); # getcodeで検出された文字コードでencodingsに指定されているものがあれば採用。 # 無ければencodingsの一番最初を採用する。 (UTF-8をSJISと認識したりするため。) my $use_encoding = ((map {$auto_charset eq $_ ? $_ : ()} @encodings), @encodings)[0]; $this->set($str, $use_encoding); } return $this; } sub AUTOLOAD { my ($this, @args) = @_; if ($AUTOLOAD =~ /::DESTROY$/) { # DESTROYは伝達させない。 return; } (my $method = $AUTOLOAD) =~ s/.+?:://g; # define method eval "sub $method { shift->{unijp}->$method(\@_); }"; no strict "refs"; goto &$AUTOLOAD; } END_OF_JCODE_COMPAT } else { if (eval('use Jcode;')) { die "Couldn't load Unicode::Japanese or Jcode!"; } } } __END__