#!/usr/bin/perl
# keitairc
# $Id: keitairc,v 1.31 2007/09/27 22:20:01 morimoto Exp $
#
# Copyright (c) 2003-2007 Jun Morimoto <morimoto@mrmt.net>
# This program is covered by the GNU General Public License 2
#
# Depends: libunicode-japanese-perl, libpoe-component-irc-perl,
#   liburi-perl, libwww-perl, libappconfig-perl, libproc-daemon-perl

my $rcsid = q$Id: keitairc,v 1.31 2007/09/27 22:20:01 morimoto Exp $;
my ($version) = $rcsid =~ m#,v ([0-9.]+)#;

use strict;
use Unicode::Japanese;
use POE;
use POE::Component::Server::TCP;
use POE::Filter::HTTPD;
use POE::Component::IRC;
use URI::Escape;
use HTTP::Response;
use Proc::Daemon;
use AppConfig qw(:argcount);

use constant true => 1;
use constant false => 0;
use constant cookie_ttl => 86400 * 3;  # 3 days

our $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
	   ping_delay reconnect_delay
	   daemonize pid_dir)
);

$config->ping_delay(30);
$config->reconnect_delay(10);

if(defined $ARGV[0] && -e $ARGV[0]){
	try_config($ARGV[0]);
	shift(@ARGV);
}else{
	try_config('/etc/keitairc');
	try_config($ENV{HOME} . '/.keitairc');
}

$config->args;

if(defined $config->daemonize){
	Proc::Daemon::Init;
	if (defined $config->pid_dir) {
		if (open(PID, '> ' . $config->pid_dir . '/keitairc.pid')) {
			print PID $$, "\n";
			close(PID);
		}
	}
}

our $docroot = '/';
if(defined $config->web_root){
	$docroot = $config->web_root;
}

# join しているチャネルの名称を記録するハッシュ
# 文字列はjisで保存されているので注意
our %channel_name;

# join しているチャネルの名称を記録するハッシュ
# 文字列はjisで保存されているので注意
our %channel_topic;

# チャネルの会話内容を記録するハッシュ
# 文字列はeucで保存されているので注意
our (%channel_buffer, %channel_recent);

# 各チャネルの最終アクセス時刻、最新発言時刻
our %channel_mtime;

# unread lines
# 文字列はeucで保存されているので注意
our %unread_lines;

# chk
our $message_added;
our $connected = false,

# irc component
our $irc = POE::Component::IRC->spawn(
	Alias => 'keitairc_irc',
	Nick => $config->irc_nick,
	Username => $config->irc_username,
	Ircname => $config->irc_desc,
	Server => $config->irc_server,
	Port => $config->irc_port,
	Password => $config->irc_password);
POE::Session->create(
	heap => {
		seen_traffic => false,
		disconnect_msg => true,
	},
	inline_states => {
		_start => \&on_irc_start,
		irc_001 => \&on_irc_001,
		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,
		autoping => \&do_autoping,
		connect => \&do_connect,
		irc_disconnected => \&on_irc_reconnect,
		irc_error => \&on_irc_reconnect,
		irc_socketerr => \&on_irc_reconnect
	});

# 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 try_config{
	my $file = shift;
	if(-e $file){
		$config->file($file);
	}
}

################################################################
sub on_irc_start{
	$irc->yield(register => 'all');
	$irc->yield(connect => {});
}

################################################################
sub on_irc_001{
	my ($kernel,$heap, $sender) = @_[KERNEL, HEAP, SENDER];
	for my $channel (sort keys %channel_name){
		&add_message($channel, undef, 'Connected to irc server!');
	}
	$heap->{disconnect_msg} = true;
	%channel_name = ();
	$kernel->delay(autoping => $config->ping_delay);
}

################################################################
sub on_irc_join{
	my ($kernel, $heap, $who, $channel) = @_[KERNEL, HEAP, 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");
	}
	$heap->{seen_traffic} = true;
	$heap->{disconnect_msg} = true;
	$connected = true;
}

################################################################
sub on_irc_part{
	my ($kernel, $heap, $who, $channel) = @_[KERNEL, HEAP, 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");
	}
	$heap->{seen_traffic} = true;
	$heap->{disconnect_msg} = true;
}

################################################################
sub on_irc_public{
	my ($kernel, $heap, $who, $channel, $msg) = @_[KERNEL, HEAP, ARG0 .. ARG2];
	$who =~ s/!.*//;
	$channel = $channel->[0];
	$msg = Unicode::Japanese->new($msg, 'jis')->euc;
	add_message($channel, $who, $msg);
	$heap->{seen_traffic} = true;
	$heap->{disconnect_msg} = true;
}

################################################################
sub on_irc_notice{
	my ($kernel, $heap, $who, $channel, $msg) = @_[KERNEL, HEAP, ARG0 .. ARG2];
	$who =~ s/!.*//;
	$channel = $channel->[0];
	$msg = Unicode::Japanese->new($msg, 'jis')->euc;
	add_message($channel, $who, $msg);
	$heap->{seen_traffic} = true;
	$heap->{disconnect_msg} = true;
}

################################################################
sub on_irc_topic{
	my ($kernel, $heap, $who, $channel, $topic) = @_[KERNEL, HEAP, ARG0 .. ARG2];
	$who =~ s/!.*//;
	$topic = Unicode::Japanese->new($topic, 'jis')->euc;
	add_message($channel, undef, "$who set topic: $topic");
	$channel_topic{canon_name($channel)} = $topic;
	$heap->{seen_traffic} = true;
	$heap->{disconnect_msg} = true;
}

################################################################
sub on_irc_topicraw{
	my ($kernel, $heap, $raw) = @_[KERNEL, HEAP, ARG1];
	my ($channel, $topic) = split(/ :/, $raw, 2);
	$channel_topic{canon_name($channel)} = $topic;
	$heap->{seen_traffic} = true;
	$heap->{disconnect_msg} = true;
}

################################################################
sub on_irc_ctcp_action{
	my ($kernel, $heap, $who, $channel, $msg) = @_[KERNEL, HEAP, ARG0 .. ARG2];
	$who =~ s/!.*//;
	$channel = $channel->[0];
	$msg = sprintf('* %s %s', $who, Unicode::Japanese->new($msg, 'jis')->euc);
	add_message($channel, '', $msg);
	$heap->{seen_traffic} = true;
	$heap->{disconnect_msg} = true;
}

################################################################
sub do_connect{
	my ($kernel, $heap) = @_[KERNEL, HEAP];
	$kernel->post(keitairc_irc => connect => {});
}

################################################################
sub do_autoping{
	my ($kernel, $heap) = @_[KERNEL, HEAP];
	$kernel->post(keitairc_irc => time) unless $heap->{seen_traffic};
	$heap->{seen_traffic} = false;
	$kernel->delay(autoping => $config->ping_delay);
}

################################################################
sub on_irc_reconnect{
	my ($kernel, $heap) = @_[KERNEL, HEAP];
	if ($heap->{disconnect_msg}) {
		for my $channel (sort keys %channel_name){
			add_message($channel, undef, 'Disconnected from irc server, trying to reconnect...');
		}
	}
	$heap->{disconnect_msg} = false;
	$connected = false;
	$kernel->delay(connect => $config->reconnect_delay);
}

################################################################
# $msg は EUC になっているはず
# $channel は jis できてるぞ
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);
	}

	$channel_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/&/&amp;/g;
	s/>/&gt;/g;
	s/</&lt;/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 {
		$channel_mtime{$b} <=> $channel_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++;

		# 未読行数
		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 %channel_topic){
		$buf .= qq(# <a href="$docroot,topics" accesskey="#">topics</a><br>);
	}

	$buf .= qq( - keitairc $version);
	$buf;
}

################################################################
# チャネル名称を短かくする
sub compact_channel_name{
	local($_) = shift;

	# #name:*.jp を %name に
	if(s/:\*\.jp$//){
		s/^#/%/;
	}

	# 末尾の単独の @ は取る (plumプラグインのmulticast.plm対策)
	s/\@$//;

	Unicode::Japanese->new($_, 'jis')->euc;
}

################################################################
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://mgw.hatena.ne.jp/?url=%s&noimage=0&split=1">[ph]</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]+)|link_url($1)|eg){
			unless(s|\b(www\.[/!-\177]+)|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="Content-Type" content="text/html; charset=Shift_JIS" />';
	$content .= '<meta http-equiv="Cache-Control" content="max-age=0" />';

	# POST されてきたものは発言
	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);
			$irc->yield(privmsg => $channel => Unicode::Japanese->new($message, 'sjis')->jis);
			add_message($channel, $config->irc_nick,
				    Unicode::Japanese->new($message, 'jis')->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>' . Unicode::Japanese->new($channel_name{$canon_channel}, 'jis')->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),
							    Unicode::Japanese->new($channel_name{$canon_channel}, 'jis')->euc);
					$content .= escape(Unicode::Japanese->new($channel_topic{$canon_channel}, 'jis')->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 .= sprintf('<title>%s: %s</title>', $config->web_title, compact_channel_name($channel));
		$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(Unicode::Japanese->new($content, 'euc')->sjis);
	$heap->{client}->put($response);
	$kernel->yield('shutdown');
}

__END__