#!/usr/local/bin/perl
# keitairc
# $Id: keitairc,v 1.19 2004/04/08 15:27:57 morimoto Exp $
#
# Copyright (c) 2003 Jun Morimoto <morimoto@xantia.citroen.org>
# 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

# Copyright of Changes (c) 2003 IKARASHI Yoshinori <yoosee@init.org>
#
# $Id$
#

# Cookie Version
# Copyright of Changes (c) 2003 HICHISATO Jun <hichisato@maid.st>
#
# $Id$
#

# V1.6 Based Merge Version (yoosee + Cookie + yukinon)
# Copyright of Changes (c) 2003 HIIRAGI Yukio <yukio@tls.org>
#
# $Id$
#

# utf8 uri + use Unicode::Japanese
# Copyright of Changes (c) 2004 Topia <topia@clovery.jp>
#
# $Id$
#


my $rcsid = q$Id: keitairc,v 1.19 2004/04/08 15:27:57 morimoto Exp $;
my ($version) = $rcsid =~ m#,v ([0-9.]+)#;

# yukinon version
$version .= "+y5";
# topia version (utf8, Unicode::Japanese)
$version .= "+t3";

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

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 show_newmsgonly
			       web_input_encoding uri_prefix)
			    );

$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 (%atime, %mtime);

# unread lines
my %unread;

# chk
my ($send_chk, $update_chk);

# Console
my $console = "*Console*";

# 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_quit => \&on_irc_quit,
		  irc_nick => \&on_irc_nick,
		  );

# 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}++;
}

################################################################
sub on_irc_join{
    my ($kernel, $who, $channel) = @_[KERNEL, ARG0, ARG1];

    for my $clist (keys(%channel_name)) {
	my $dst = lc($clist);
	my $src = lc($channel);
	if ($dst eq $src) {
	    $channel = $clist;
	    last;
	}
    }

    $who =~ s/!.*//;
    $channel_name{$channel}++;
    unless ($who eq $config->irc_nick) {
	# &add_message($channel, undef, "$who has joined");
	my $msg = sprintf('%s has joind channel %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];

    for my $clist (keys(%channel_name)) {
	my $dst = lc($clist);
	my $src = lc($channel);
	if ($dst eq $src) {
	    $channel = $clist;
	    last;
	}
    }

    $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, undef, "$who has left");
	my $msg = sprintf('%s has left channel %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/!.*//;
    $msg = Jcode->new($msg, 'jis')->euc;
    &add_message($console, undef, "$who has left IRC($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);
    }

    &add_message($console, undef, "$who -> $nick");
}


################################################################
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) = @_;

    for my $clist (keys(%channel_name)) {
	my $dst = lc($clist);
	my $src = lc($channel);
	if ($dst eq $src) {
	    $channel = $clist;
	    last;
	}
    }

    # 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} > $config->web_lines) {
	$unread{$channel} = $config->web_lines;
    }

    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);
    }

    if ($channel eq $console) {
	$mtime{$channel} = 0;
    } else {
	$mtime{$channel} = time;
    }
}

################################################################
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;
    s/\"/&quot;/g;
    $_;
}

################################################################
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,
				&channel_to_uri($channel),
				Jcode->new(&compact_channel_name($channel), 'jis')->euc);
	}else{
		$buf .= sprintf('<a href="%s%s">%s</a>',
				$docroot,
				&channel_to_uri($channel),
				Jcode->new(&compact_channel_name($channel), 'jis')->euc);
	}

	$accesskey++;

	# 未読行数
	if($unread{$channel} > 0){
		$buf .= sprintf(' <a href="%s%s.update">%d</a>',
				$docroot,
				&channel_to_uri($channel),
				$unread{$channel});
	}
	$buf .= '<br>';
    }

    $buf .= qq(0 <a href="$docroot" accesskey="0">refresh list</a><br>);
    $buf .= qq( - keitairc $version);
    $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('<a href="%s%s">%s</a>',
			   $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)<br>\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;

    # #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];
    my $uri_prefix = defined $config->uri_prefix ? $config->uri_prefix : '';

    for (@src){
	next unless defined;
	next unless length;

	$_ = &escape($_);

	unless(s,\b(https?://[!-;=-\177]+)\b,<a href="${uri_prefix}$1">$1</a>,g){
	    unless(s|\b(www\.[!-\177]+)\b|<a href="${uri_prefix}http://$1">$1</a>|g){
		# 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;
    my $ccusername = '';
    my $ccpasswd = '';
    my $cookie_auth = 0;
    my $name;
    my $value;
    my $xx;
    my $cookie = $request->header('Cookie');
    my @val;
    foreach $xx (split(/; */,$cookie)) {
	($name, $value) = split(/=/, $xx);
        $value =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack("C", hex($1))/eg;
        $COOKIE{$name} = $value;
    }
    
    if ($COOKIE{'username'} ne '') {
		$ccusername = $COOKIE{'username'};
    }
    if ($COOKIE{'passwd'} ne '') {
 	$ccpasswd = $COOKIE{'passwd'};
	if ($ccusername eq $config->web_username && $ccpasswd eq $config->web_password) {
		$cookie_auth = 1;
	} else {
		$cookie_auth = 0;
	}
    }

    if(defined($config->web_username) && $cookie_auth eq 0){
	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;
	}
    }

    $ccusername = $config->web_username;
    $ccpasswd   = $config->web_password;

    my $uri = $request->uri;
    my $content = '<html><head>';
    $content .= '<meta http-equiv="Cache-Control" content="no-cache" />';

    # 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_to_channel($uri);
	    if ($message =~ /^\//) {
		$message =~ s/\///;
		my @postcmd = split(/ /, $message);
		$poe_kernel->post('keitairc',
			      Jcode->new(@postcmd[0], $config->web_input_encoding)->jis,
			      Jcode->new(@postcmd[1], $config->web_input_encoding)->jis);
	    } 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);
	    }
	}
    }

    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_to_channel($uri);

	$content .= '<title>' . $config->web_title . ": " .
	    Jcode->new($channel, 'jis')->euc . "</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, &channel_to_uri($channel));
	$content .= '<input type="text" name="m" size="17">';
	$content .= '<input type="submit" accesskey="1" value="OK">';
	$content .= qq(<a accesskey="8" href="$docroot">List</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 .= '<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", &channel_to_uri($channel));
		} else {
		  $content .= &render($channel_buffer{$channel});
		}
		$content .= '<a name="2"></a>';
	    }else{
		$content .= 'no message here yet';
	    }
	}else{
	    $content .= "no such channel";
	}

	# add recent messages in all channels
	if (($update_chk ne 1) && ($send_chk ne 1)) {
	    $content .= '<hr>';
	    $content .= recent_all_messages($channel, 10);
	}

	# clear check flags
	$send_chk = 0;

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

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

	# add channel list link
	$content .= '<hr>';
	# $content .= qq(<a href="$docroot">Channel List</a>);

	$atime{$channel} = time;
    }

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

    # cookie記録
    my @Months = ('','Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
    my @WeekDays =('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time+86400*3);
    $mon++;
    $year+=1900;
    
    my $response = HTTP::Response->new(200);
    my $expire = sprintf("%.3s, %.2d-%.3s-%.4s %.2d:%.2d:%.2d",$WeekDays[$wday],$mday,$Months[$mon],$year,$hour,$min,$sec);
    $response->push_header('Set-Cookie',"username=$ccusername; expires=$expire; \n");
    $response->push_header('Set-Cookie',"passwd=$ccpasswd; expires=$expire; \n");

    # こっからレンダリング
    # my $response = HTTP::Response->new(200);
    $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);
}

package Jcode;
# Jcode compat
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__