#!/usr/bin/perl
# keitairc
-# $Id: keitairc,v 1.20 2004-06-07 01:27:57 morimoto Exp $
+# $Id: keitairc,v 1.30 2006-08-03 07:19:47 morimoto Exp $
#
-# Copyright (c) 2003 Jun Morimoto <morimoto@xantia.citroen.org>
+# 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.20 2004-06-07 01:27:57 morimoto Exp $;
+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 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,
},
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)
);
# join \e$B$7$F$$$k%A%c%M%k$NL>>N$r5-O?$9$k%O%C%7%e\e(B
my %channel_name;
+# join \e$B$7$F$$$k%A%c%M%k$NL>>N$r5-O?$9$k%O%C%7%e\e(B
+my %topic;
+
# \e$B%A%c%M%k$N2qOCFbMF$r5-O?$9$k%O%C%7%e\e(B
my (%channel_buffer, %channel_recent);
my %mtime;
# unread lines
-my %unread;
+my %unread_lines;
# chk
-my ($send_chk, $update_chk);
+my ($message_added);
# irc component
POE::Component::IRC->new('keitairc');
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
# chop off after the gap (bug workaround of madoka)
$channel =~ s/ .*//;
+ my $canon_channel = &canon_name($channel);
- $channel_name{$channel}++;
+ $channel_name{$canon_channel} = $channel;
unless ($who eq $config->irc_nick) {
&add_message($channel, undef, "$who joined");
}
# 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{$channel};
+ delete $channel_name{$canon_channel};
} else {
&add_message($channel, undef, "$who leaves");
}
}
################################################################
+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 \e$B$O\e(B EUC \e$B$K$J$C$F$$$k$O$:\e(B
# $channel \e$B$O\e(B jis \e$B$G$-$F$k$>\e(B
sub add_message{
$message = sprintf('%s %s', &now, $msg);
}
- my @tmp = split("\n", $channel_buffer{$channel});
+ my $canon_channel = &canon_name($channel);
+ my @tmp = split("\n", $channel_buffer{$canon_channel});
push @tmp, $message;
- my @tmp2 = split("\n", $channel_recent{$channel});
+ my @tmp2 = split("\n", $channel_recent{$canon_channel});
push @tmp2, $message;
if(@tmp > $config->web_lines){
- $channel_buffer{$channel} =
+ $channel_buffer{$canon_channel} =
join("\n", splice(@tmp, -$config->web_lines));
}else{
- $channel_buffer{$channel} = join("\n", @tmp);
+ $channel_buffer{$canon_channel} = join("\n", @tmp);
}
if(@tmp2 > $config->web_lines){
- $channel_recent{$channel} =
- join("\n", splice(@tmp2, -$config->web_lines));
+ $channel_recent{$canon_channel} =
+ join("\n", @tmp2[1 .. $config->web_lines]);
}else{
- $channel_recent{$channel} = join("\n", @tmp2);
+ $channel_recent{$canon_channel} = join("\n", @tmp2);
}
- $mtime{$channel} = time;
+ $mtime{$canon_channel} = time;
# unread lines
- $unread{$channel} = scalar(@tmp2);
+ $unread_lines{$canon_channel} = scalar(@tmp2);
- if ($unread{$channel} > $config->web_lines) {
- $unread{$channel} = $config->web_lines;
+ if($unread_lines{$canon_channel} > $config->web_lines){
+ $unread_lines{$canon_channel} = $config->web_lines;
}
}
################################################################
sub escape{
local($_) = shift;
- s/&/&/;
- s/>/>/;
- s/</</;
+ s/&/&/g;
+ s/>/>/g;
+ s/</</g;
$_;
}
sub index_page{
my $buf;
my $accesskey = 1;
+ my $channel;
- for my $channel (sort {
+ for my $canon_channel (sort {
$mtime{$b} <=> $mtime{$a};
}(keys(%channel_name))){
+ $channel = $channel_name{$canon_channel};
$buf .= &label($accesskey);
$accesskey++;
# \e$BL$FI9T?t\e(B
- if($unread{$channel} > 0){
- $buf .= sprintf(' <a href="%s%s.update">%d</a>',
+ if($unread_lines{$canon_channel}){
+ $buf .= sprintf(' <a href="%s%s,recent">%s</a>',
$docroot,
uri_escape($channel),
- $unread{$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;
}
}
################################################################
+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;
$_ = &escape($_);
- unless(s,\b(https?://[!-;=-\177]+)\b,<a href="$1">$1</a>,g){
- unless(s|\b(www\.[!-\177]+)\b|<a href="http://$1">$1</a>|g){
+ 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;
return;
}
- if(defined($config->web_username)){
- unless($request->headers->authorization_basic eq
- $config->web_username . ':' . $config->web_password){
+ # 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;
Jcode->new($message)->jis);
&add_message($channel, $config->irc_nick,
Jcode->new($message)->euc);
-
- # set flag for "send message"
- $send_chk = 1;
+ $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>';
+ $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|^/||;
- $update_chk = ($uri =~ /.*.update/);
- if ($update_chk eq 1) {
- $uri =~ s/.update//;
- }
+ # 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);
$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">back[8]</a><br>);
- # $content .= '<input type="submit" accesskey="1" value="聆">';
+ $content .= qq(<a accesskey="8" href="$docroot">ch list[8]</a><br>);
$content .= '</form>';
- if(defined($channel_name{$channel})){
- if(defined($channel_buffer{$channel}) &&
- length($channel_buffer{$channel})){
+ 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 ((($update_chk eq 1)||((defined $config->show_newmsgonly) && ($send_chk eq 1)))) {
- $content .= &render($channel_recent{$channel});
- $content .= sprintf('<a accesskey="5" href="%s%s">
- ..more[5]</a>', $docroot, uri_escape($channel));
+ 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{$channel});
+ $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";
+ $content .= 'no such channel';
}
# clear check flags
- $send_chk = 0;
+ $message_added = false;
# clear unread counter
- $unread{$channel} = 0;
+ $unread_lines{$canon_channel} = 0;
# clear recent messages buffer
- $channel_recent{$channel} = '';
+ $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);
OSDN Git Service
