#!/usr/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 しているチャネルの名称を記録するハッシュ
my %channel_name;

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

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

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

# unread lines
my %unread_lines;

# chk
my ($message_added);

# 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_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 は 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);
    }

    $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 {
	$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++;

	# 未読行数
	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;
}

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

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

    # 末尾の単独の @ は取る (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 されてきたものは発言
    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__