#!/usr/bin/perl
# keitairc
# $Id: keitairc,v 1.13 2004-03-21 11:04:37 morimoto Exp $
#
# Copyright (c) 2003 Jun Morimoto <morimoto@xantia.citroen.org>
# 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.13 2004-03-21 11:04:37 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);

my $config = AppConfig->new(
			    {
				CASE => 1,
				GLOBAL => {
				    ARGCOUNT => ARGCOUNT_ONE,
				}
			    },
			    qw(irc_nick irc_username irc_desc
			       irc_server irc_port irc_password
			       web_port web_title web_lines web_root
			       web_username web_password)
			    );

$config->file('/etc/keitairc');
$config->file($ENV{'HOME'} . '/.keitairc');
$config->args;

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

# join しているチャネルの名称を記録するハッシュ
my %channel_name;

# チャネルの会話内容を記録するハッシュ
my (%channel_buffer, %channel_recent);

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

# unread lines
my %unread;

# chk
my ($send_chk, $update_chk);

# 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,
		  );

# 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];
    $channel_name{$channel}++;
}

################################################################
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/ .*//;

    if ($who eq $config->irc_nick) {
       delete $channel_name{$channel};
    } else {
       &add_message($channel, 'SYSOP', $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);
}

################################################################
# $msg は EUC になっているはず
# $channel は jis できてるぞ
sub add_message{
    my($channel, $who, $msg) = @_;

    my $message = sprintf('%s %s> %s', &now, $who, $msg);

    my @tmp = split("\n", $channel_buffer{$channel});
    push @tmp, $message;

    my @tmp2 = split("\n", $channel_recent{$channel});
    push @tmp2, $message;

    if(@tmp > $config->web_lines){
	$channel_buffer{$channel} =
		join("\n", splice(@tmp, -$config->web_lines));
    }else{
	$channel_buffer{$channel} = join("\n", @tmp);
    }

    if(@tmp2 > $config->web_lines){
	$channel_recent{$channel} =
		join("\n", splice(@tmp2, -$config->web_lines));
    }else{
	$channel_recent{$channel} = join("\n", @tmp2);
    }

    $mtime{$channel} = time;

    # unread lines
    $unread{$channel} = @tmp2;

    if ($unread{$channel} > $config->web_lines) {
	$unread{$channel} = $config->web_lines;
    }
}

################################################################
sub now{
    my ($sec,$min,$hour) = localtime(time);
    sprintf('%02d:%02d', $hour, $min);
}

################################################################
sub escape{
    local($_) = shift;
    s/&/&amp;/;
    s/>/&gt;/;
    s/</&lt;/;
    $_;
}

################################################################
sub label{
    my $accesskey = shift;

    if($accesskey < 10){
	sprintf('%d ', $accesskey);
    }else{
	'  ';
    }
}

################################################################
sub index_page{
    my $buf;
    my $accesskey = 1;

    for my $channel (sort {
	$mtime{$b} <=> $mtime{$a};
    }(keys(%channel_name))){

	$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{$channel} > 0){
		$buf .= sprintf(' <a href="%s%s.update">%d</a>',
				$docroot,
				uri_escape($channel),
				$unread{$channel});
	}
	$buf .= '<br>';
    }

    $buf .= qq(0 <a href="$docroot" accesskey="0">refresh list</a><br>);
    $buf .= qq( - keitairc $version);
    $buf;
}

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

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

    # 末尾の単独の @ は取る (for multicast.plm)
    s/\@$//;

    $_;
}

################################################################
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,(http://[!-;=-\177]+),<a href="$1">$1</a>,g){
	    unless(s|(www\.[!-\177]+)|<A HREF="http://$1">$1</A>|g){
		# phone to
		unless(s|(0\d{1,3}[-(]?\d{2,4}[-)]?\d{4})|<a href="tel:$1">$1</a>|g){
		    s|(\w[\w.+=-]+\@[\w.-]+[\w])|<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;
    }

    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>';

    # 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);
	    $poe_kernel->post('keitairc',
			      'privmsg',
			      Jcode->new($channel)->jis,
			      Jcode->new($message)->jis);
	    &add_message($channel, $config->irc_nick,
			 Jcode->new($message)->euc);

	    # set flag for "send message"
	    $send_chk = 1;
	}
    }

    if($uri eq '/'){
	$content .= '<title>' . $config->web_title . '</title>';
	$content .= '</head>';
	$content .= '<body>';
	$content .= &index_page;
    }else{
	$uri =~ s|^/||;

	$update_chk = ($uri =~ /.*.update/);
	if ($update_chk eq 1) {
		$uri =~ s/.update//;
	}

	my $channel = uri_unescape($uri);

	$content .= '<title>' . $config->web_title . ": $channel</title>";
	$content .= '<body>';

	$content .= '<a name="1"></a>';
	$content .= '<a accesskey="7" href="#1"></a>';
	$content .= '<a accesskey="8" href="../"></a>';

	$content .= sprintf('<form action="%s%s" method="post">',
			    $docroot, $uri);
	$content .= '<input type="text" name="m" size="10">';
	$content .= '<input type="submit" accesskey="1" value="OK[1]">';
        $content .= '<a href="../">back[8]</a><br>';
	# $content .= '<input type="submit" accesskey="1" value="&#63920;">';
	$content .= '</form>';

	if(defined($channel_name{$channel})){
	    if(defined($channel_buffer{$channel}) &&
	       length($channel_buffer{$channel})){
		$content .= qq(<a accesskey="8" href="$docroot"></a>);
		$content .= '<a accesskey="9" href="#2"></a>';
		if (($update_chk eq 1)||($send_chk eq 1)) {
		  $content .= &render($channel_recent{$channel});
		  $content .= sprintf('<a accesskey="5" href="%s%s">
			..more[5]</a>', "../", uri_escape($channel));
		} else {
		  $content .= &render($channel_buffer{$channel});
		}
		$content .= '<a name="2"></a>';
	    }else{
		$content .= 'no message here yet';
	    }
	}else{
	    $content .= "no such channel";
	}

	# clear check flags
	$send_chk = 0;

	# clear unread counter
        $unread{$channel} = 0;

	# clear recent messages buffer
	$channel_recent{$channel} = '';
    }

    $content .= '</body></html>';

    my $response = HTTP::Response->new(200);
    $response->push_header('Content-type', 'text/html; charset=Shift_JIS');
    $response->content(Jcode->new($content)->sjis);
    $heap->{client}->put($response);
    $kernel->yield('shutdown');
}

__END__