#!/usr/local/bin/perl
# keitairc
# $Id: keitairc,v 1.30 2006/08/03 07:19:47 morimoto Exp $
#
# Copyright (c) Jun Morimoto <morimoto@mrmt.net>
# This program is covered by the GNU General Public License 2
#
# Depends: libjcode-pm-perl, libpoe-component-irc-perl,
# liburi-perl, libwww-perl, libappconfig-perl
my $rcsid = q$Id: keitairc,v 1.30 2006/08/03 07:19:47 morimoto Exp $;
my ($version) = $rcsid =~ m#,v ([0-9.]+)#;
use strict;
use Jcode;
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
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 au_pcsv use_cookie
web_port web_title web_lines web_root
web_username web_password show_newmsgonly)
);
$config->file('/etc/keitairc');
$config->file($ENV{'HOME'} . '/.keitairc');
$config->args;
my $docroot = '/';
if(defined $config->web_root){
$docroot = $config->web_root;
}
# join $B$7$F$$$k%A%c%M%k$NL>>N$r5-O?$9$k%O%C%7%e(B
my %channel_name;
# join $B$7$F$$$k%A%c%M%k$NL>>N$r5-O?$9$k%O%C%7%e(B
my %topic;
# $B%A%c%M%k$N2qOCFbMF$r5-O?$9$k%O%C%7%e(B
my (%channel_buffer, %channel_recent);
# $B3F%A%c%M%k$N:G=*%"%/%;%9;~9o!":G?7H/8@;~9o(B
my %mtime;
# unread lines
my %unread_lines;
# chk
my ($message_added);
# irc component
POE::Component::IRC->spawn(alias => 'keitairc');
POE::Session->create(
inline_states => {
_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,
}
);
# 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
});
}
################################################################
sub on_irc_join{
my ($kernel, $who, $channel) = @_[KERNEL, ARG0, ARG1];
$who =~ s/!.*//;
# chop off after the gap (bug workaround of madoka)
$channel =~ s/ .*//;
my $canon_channel = &canon_name($channel);
$channel_name{$canon_channel} = $channel;
unless ($who eq $config->irc_nick) {
&add_message($channel, undef, "$who joined");
}
}
################################################################
sub on_irc_part{
my ($kernel, $who, $channel) = @_[KERNEL, ARG0, ARG1];
$who =~ s/!.*//;
# chop off after the gap (bug workaround of POE::Filter::IRC)
$channel =~ s/ .*//;
my $canon_channel = &canon_name($channel);
if ($who eq $config->irc_nick) {
delete $channel_name{$canon_channel};
} else {
&add_message($channel, undef, "$who leaves");
}
}
################################################################
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");
$topic{&canon_name($channel)} = $topic;
}
################################################################
sub on_irc_topicraw{
my ($kernel, $raw) = @_[KERNEL, ARG1];
my ($channel, $topic) = split(/ :/, $raw, 2);
$topic{&canon_name($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);
}
################################################################
# $msg $B$O(B EUC $B$K$J$C$F$$$k$O$:(B
# $channel $B$O(B jis $B$G$-$F$k$>(B
sub add_message{
my($channel, $who, $msg) = @_;
my $message;
if(length $who){
$message = sprintf('%s %s> %s', &now, $who, $msg);
}else{
$message = sprintf('%s %s', &now, $msg);
}
my $canon_channel = &canon_name($channel);
my @tmp = split("\n", $channel_buffer{$canon_channel});
push @tmp, $message;
my @tmp2 = split("\n", $channel_recent{$canon_channel});
push @tmp2, $message;
if(@tmp > $config->web_lines){
$channel_buffer{$canon_channel} =
join("\n", splice(@tmp, -$config->web_lines));
}else{
$channel_buffer{$canon_channel} = join("\n", @tmp);
}
if(@tmp2 > $config->web_lines){
$channel_recent{$canon_channel} =
join("\n", @tmp2[1 .. $config->web_lines]);
}else{
$channel_recent{$canon_channel} = join("\n", @tmp2);
}
$mtime{$canon_channel} = time;
# unread lines
$unread_lines{$canon_channel} = scalar(@tmp2);
if($unread_lines{$canon_channel} > $config->web_lines){
$unread_lines{$canon_channel} = $config->web_lines;
}
}
################################################################
sub now{
my ($sec,$min,$hour) = localtime(time);
sprintf('%02d:%02d', $hour, $min);
}
################################################################
sub escape{
local($_) = shift;
s/&/&/g;
s/>/>/g;
s/</</g;
$_;
}
################################################################
sub label{
my $accesskey = shift;
if($accesskey < 10){
sprintf('%d ', $accesskey);
}else{
' ';
}
}
################################################################
sub index_page{
my $buf;
my $accesskey = 1;
my $channel;
for my $canon_channel (sort {
$mtime{$b} <=> $mtime{$a};
}(keys(%channel_name))){
$channel = $channel_name{$canon_channel};
$buf .= &label($accesskey);
if($accesskey < 10){
$buf .= sprintf('<a accesskey="%1d" href="%s%s">%s</a>',
$accesskey,
$docroot,
uri_escape($channel),
&compact_channel_name($channel));
}else{
$buf .= sprintf('<a href="%s%s">%s</a>',
$docroot,
uri_escape($channel),
&compact_channel_name($channel));
}
$accesskey++;
# $BL$FI9T?t(B
if($unread_lines{$canon_channel}){
$buf .= sprintf(' <a href="%s%s,recent">%s</a>',
$docroot,
uri_escape($channel),
$unread_lines{$canon_channel});
}
$buf .= '<br>';
}
$buf .= qq(0 <a href="$docroot" accesskey="0">refresh list</a><br>);
if(grep($unread_lines{$_}, keys %unread_lines)){
$buf .= qq(* <a href="$docroot,recent" accesskey="*">recent</a><br>);
}
if(keys %topic){
$buf .= qq(# <a href="$docroot,topics" accesskey="#">topics</a><br>);
}
$buf .= qq( - keitairc $version);
$buf;
}
################################################################
# $B%A%c%M%kL>>N$rC;$+$/$9$k(B
sub compact_channel_name{
local($_) = shift;
# #name:*.jp $B$r(B %name $B$K(B
if(s/:\*\.jp$//){
s/^#/%/;
}
# $BKvHx$NC1FH$N(B @ $B$O<h$k(B (for multicast.plm)
s/\@$//;
$_;
}
################################################################
sub canon_name{
local($_) = shift;
tr/A-Z[\\]^/a-z{|}~/;
$_;
}
################################################################
sub link_url{
my $url = shift;
my @buf;
push @buf, sprintf('<a href="%s">%s</a>', $url, $url);
if(defined $config->au_pcsv && $ENV{HTTP_USER_AGENT} =~ /^KDDI-/){
push @buf, sprintf('<a href="device:pcsiteviewer?url=%s">[PCSV]</a>', $url);
}
push @buf, sprintf('<a href="http://www.google.com/gwt/n?u=%s&hl=ja&mrestrict=xhtml|chtml&lr=&inlang=ja&client=ms-kddi-jp">[GWT]</a>', uri_escape($url));
join(' ', @buf);
}
################################################################
sub render{
local($_);
my @buf;
my @src = (reverse(split("\n", shift)))[0 .. $config->web_lines];
for (@src){
next unless defined;
next unless length;
$_ = &escape($_);
unless(s|\b(https?://[!-;=-\177]+)\b|link_url($1)|eg){
unless(s|\b(www\.[!-\177]+)\b|link_url($1)|eg){
# phone to
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){
s|\b(\w[\w.+=-]+\@[\w.-]+[\w]\.[\w]{2,4})\b|<a href="mailto:$1">$1</a>|g;
}
}
}
s/\s+$//;
s/\s+/ /g;
push @buf, $_;
}
'<pre>' . join("\n", @buf) . '</pre>';
}
################################################################
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;
}
# 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 = '<html><head>';
$content .= '<meta http-equiv="Cache-Control" content="max-age=0" />';
# POST $B$5$l$F$-$?$b$N$OH/8@(B
if($request->method =~ /POST/i){
my $message = $request->content;
$message =~ s/^m=//;
$message =~ s/\+/ /g;
$message = uri_unescape($message);
if(length($message)){
$uri =~ s|^/||;
my $channel = uri_unescape($uri);
$poe_kernel->post('keitairc',
'privmsg',
Jcode->new($channel)->jis,
Jcode->new($message)->jis);
&add_message($channel, $config->irc_nick,
Jcode->new($message)->euc);
$message_added = true;
}
}
# store and remove attached options from uri
my %option;
{
my @opts = split(',', $uri);
shift @opts;
grep($option{$_} = $_, @opts);
$uri =~ s/,.*//;
}
if($uri eq '/'){
$content .= '<title>' . $config->web_title . '</title>';
$content .= '</head>';
$content .= '<body>';
if($option{recent}){
# recent messages on every channel
for my $canon_channel (sort keys %channel_name){
my $channel = $channel_name{$canon_channel};
if(length($channel) &&
length($channel_recent{$canon_channel})){
$content .= '<b>' . Jcode->new($channel_name{$canon_channel})->euc . '</b>';
$content .= sprintf(' <a href="%s%s">more..</a><br>',
$docroot, uri_escape($channel));
$content .= &render($channel_recent{$canon_channel});
$unread_lines{$canon_channel} = 0;
$channel_recent{$canon_channel} = '';
$content .= '<hr>';
}
}
$content .= qq(<a accesskey="8" href="$docroot">ch list[8]</a>);
}elsif($option{topics}){
# topic on every channel
for my $canon_channel (sort keys %channel_name){
my $channel = $channel_name{$canon_channel};
if(length $channel){
$content .= sprintf(' <a href="%s%s">%s</a><br>',
$docroot, uri_escape($channel),
Jcode->new($channel_name{$canon_channel})->euc);
$content .= &escape(Jcode->new($topic{$canon_channel})->euc);
$content .= '<br>';
}
}
$content .= qq(<br><a accesskey="8" href="$docroot">ch list[8]</a>);
}else{
# channel list
$content .= &index_page;
}
}else{
# channel conversation
$uri =~ s|^/||;
# 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_unescape($uri);
$content .= '<title>' . $config->web_title . ": $channel</title>";
$content .= '</head>';
$content .= '<body>';
$content .= '<a name="1"></a>';
$content .= '<a accesskey="7" href="#1"></a>';
$content .= sprintf('<form action="%s%s" method="post">',
$docroot, uri_escape($channel));
$content .= '<input type="text" name="m" size="10">';
$content .= '<input type="submit" accesskey="1" value="OK[1]">';
$content .= qq(<a accesskey="8" href="$docroot">ch list[8]</a><br>);
$content .= '</form>';
my $canon_channel = &canon_name($channel);
if(defined($channel_name{$canon_channel})){
if(defined($channel_buffer{$canon_channel}) &&
length($channel_buffer{$canon_channel})){
$content .= '<a accesskey="9" href="#2"></a>';
if($option{recent} ||
(defined($config->show_newmsgonly) && $message_added)){
$content .= &render($channel_recent{$canon_channel});
$content .= sprintf('<a accesskey="5" href="%s%s">more[5]</a>',
$docroot, uri_escape($channel));
} else {
$content .= &render($channel_buffer{$canon_channel});
}
$content .= '<a accesskey="9" href="#2"></a>';
$content .= '<a name="2"></a>';
}else{
$content .= 'no message here yet';
}
}else{
$content .= 'no such channel';
}
# clear check flags
$message_added = false;
# clear unread counter
$unread_lines{$canon_channel} = 0;
# clear recent messages buffer
$channel_recent{$canon_channel} = '';
}
$content .= '</body></html>';
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)->sjis);
$heap->{client}->put($response);
$kernel->yield('shutdown');
}
__END__
syntax highlighted by Code2HTML, v. 0.9.1