#!/usr/bin/perl
+# -*- mode: perl; coding: utf-8 -*-
# keitairc
-# $Id: keitairc,v 1.28 2004-09-11 16:18:24 morimoto Exp $
#
-# Copyright (c) 2003 Jun Morimoto <morimoto@xantia.citroen.org>
+# Copyright (c) 2003-2010 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.28 2004-09-11 16:18:24 morimoto Exp $;
-my ($version) = $rcsid =~ m#,v ([0-9.]+)#;
+# Depends: libpoe-component-irc-perl,
+# liburi-perl, libwww-perl, libappconfig-perl, libproc-daemon-perl,
+# libhtml-template-perl
+#
+# 00location_receiver plugin use XML::Simple, so if you want to use it
+# Depends: libxml-simple-perl
-use strict;
-use Jcode;
+use Encode;
use POE;
-use POE::Component::Server::TCP;
use POE::Filter::HTTPD;
use POE::Component::IRC;
+use POE::Component::Server::TCP;
use URI::Escape;
+use HTML::Template;
use HTTP::Response;
-use AppConfig qw(:argcount);
+use HTTP::Status;
+
+use FindBin;
+use lib ("$FindBin::Bin/lib", '/usr/share/keitairc/lib');
+use Keitairc::Config;
+use Keitairc::View;
+use Keitairc::IrcBuffer;
+use Keitairc::IrcCallback;
+use Keitairc::ClientInfo;
+use Keitairc::SessionManager;
+use Keitairc::Plugins;
+use Keitairc::Log;
+use strict;
+use warnings;
+
+our $cf = new Keitairc::Config({version => '2.1a1', argv => \@ARGV});
+
+# daemonize
+if($cf->daemonize()){
+ if (eval 'require Proc::Daemon') {
+ require Proc::Daemon;
+ Proc::Daemon::Init();
+ if(length $cf->pid_dir()){
+ if (open(PID, '> ' . $cf->pid_dir() . '/' . $cf->pid_file())) {
+ print PID $$, "\n";
+ close(PID);
+ }
+ }
+ $poe_kernel->has_forked if ($poe_kernel->can('has_forked'));
+ } else {
+ warn('Proc::Daemon module is not installed, could not daemonize');
+ }
+}
-use constant true => 1;
-use constant false => 0;
-use constant cookie_ttl => 86400*3; # 3 days
+our $log = new Keitairc::Log({config => $cf});
+our $ib = new Keitairc::IrcBuffer({history => $cf->web_lines()});
+our $sm = new Keitairc::SessionManager({default_ttl => $cf->session_ttl()});
+our $pl = new Keitairc::Plugins({config => $cf});
+
+# create irc component
+our $irc = POE::Component::IRC->spawn(
+ Alias => 'keitairc_irc',
+ Nick => $cf->irc_nick(),
+ Username => $cf->irc_username(),
+ Ircname => $cf->irc_desc(),
+ Server => $cf->irc_server(),
+ Port => $cf->irc_port(),
+ Password => $cf->irc_password());
+
+# create POE session
+POE::Session->create(
+ heap => {
+ seen_traffic => 0,
+ disconnect_msg => 1,
+ Config => $cf,
+ Irc => $irc,
+ IrcBuffer => $ib,
+ },
+ inline_states => {
+ _start => \&Keitairc::IrcCallback::irc_start,
+ autoping => \&Keitairc::IrcCallback::irc_autoping,
+ connect => \&Keitairc::IrcCallback::irc_connect,
+ irc_registered => \&Keitairc::IrcCallback::irc_registered,
+ irc_001 => \&Keitairc::IrcCallback::irc_001,
+ irc_join => \&Keitairc::IrcCallback::irc_join,
+ irc_part => \&Keitairc::IrcCallback::irc_part,
+ irc_quit => \&Keitairc::IrcCallback::irc_quit,
+ irc_public => \&Keitairc::IrcCallback::irc_public,
+ irc_notice => \&Keitairc::IrcCallback::irc_notice,
+ irc_mode => \&Keitairc::IrcCallback::irc_mode,
+ irc_nick => \&Keitairc::IrcCallback::irc_nick,
+ irc_msg => \&Keitairc::IrcCallback::irc_msg,
+ irc_topic => \&Keitairc::IrcCallback::irc_topic,
+ irc_332 => \&Keitairc::IrcCallback::irc_topicraw,
+ irc_352 => \&Keitairc::IrcCallback::irc_whoreply,
+ irc_ctcp_action => \&Keitairc::IrcCallback::irc_ctcp_action,
+ irc_disconnected => \&Keitairc::IrcCallback::irc_reconnect,
+ irc_error => \&Keitairc::IrcCallback::irc_reconnect,
+ irc_socketerr => \&Keitairc::IrcCallback::irc_reconnect,
+ });
+
+# create web server component
+POE::Component::Server::TCP->new(
+ Alias => 'keitairc',
+ Port => $cf->web_listen_port(),
+ ClientFilter => 'POE::Filter::HTTPD',
+ ClientInput => \&http_request);
-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 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;
-}
+# fire up main loop
+$poe_kernel->run();
+exit 0;
-# 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;
+################################################################
+sub http_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);
+ $log->log_error($request->as_string());
+ }elsif(my $response = dispatch($request)){
+ $heap->{client}->put($response);
+ $log->log_access($heap->{'remote_ip'}, $request, $response);
+ }
-# \e$B%A%c%M%k$N2qOCFbMF$r5-O?$9$k%O%C%7%e\e(B
-my (%channel_buffer, %channel_recent);
+ $kernel->yield('shutdown');
+}
-# \e$B3F%A%c%M%k$N:G=*%"%/%;%9;~9o!":G?7H/8@;~9o\e(B
-my %mtime;
+################################################################
+sub dispatch{
+ my $request = shift;
+ my $uri = $request->uri();
+ my $ci = new Keitairc::ClientInfo($request);
-# unread lines
-my %unread_lines;
+ $log->log_debug("dispatch: $uri");
-# chk
-my ($message_added);
+ {
+ # chop off $cf->web_root()
+ my $root = $cf->web_root();
+ $uri =~ s|$root|/|;
+ }
-my $user_agent;
+ if($uri eq '/'){
+ return action_root($request);
+ }
-# 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_ctcp_action => \&on_irc_ctcp_action,
- );
+ if($uri eq '/login'){
+ return action_login($request);
+ }
-# web server component
-POE::Component::Server::TCP->new(
- Alias => 'keitairc',
- Port => $config->web_port,
- ClientFilter => 'POE::Filter::HTTPD',
- ClientInput => \&on_web_request
- );
+ if($uri eq '/login_icc'){
+ return action_login_icc($request);
+ }
-$poe_kernel->run();
-exit 0;
+ if($uri eq '/login_imodeid?guid=ON'){
+ return action_login_imodeid($request);
+ }
-################################################################
-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
- });
-}
+ for my $name ($pl->list_action_plugins()){
+ if($uri =~ m|^/(S[a-zA-Z]{10})/$name/(.*)| ||
+ $uri =~ m|^/(S[a-zA-Z]{10})/$name$|){
+ if($sm->verify({session_id => $1, user_agent => $ci->user_agent()})){
+ return add_cookie($pl->{plugins}->{$name}->{action_imprementation}($request, $name, $1, $2), $1);
+ }
+ if ($ci->is_webkit() && $cf->webkit_newui()) {
+ return action_error($request, 401);
+ } else {
+ return action_redirect_root($request);
+ }
+ }
+ }
-################################################################
-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");
- }
+ return action_public($request, $uri) || action_error($request, 404);
}
################################################################
-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");
- }
+# adds session id cookie to http response object
+sub add_cookie{
+ my $response = shift;
+ my $session_id = shift;
+
+ my ($sec, $min, $hour, $mday, $mon, $year, $wday) = localtime(time + $cf->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);
+ my $content = sprintf("sid=%s; expires=%s; path=%s; \n", $session_id, $expiration, $cf->web_root());
+ $response->push_header('Set-Cookie', $content);
+ $response;
}
################################################################
-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);
-}
+# 通常ログインのPOST先
+# パスワードをチェックして
+# 間違っていたら / へリンクして終わり
+# 合っていたらセッションを発行し /{SESSION}/index へ
+sub action_login{
+ my $request = shift;
+ my $ci = new Keitairc::ClientInfo($request);
+ my $content = $request->decoded_content();
+ my ($password) = ($content =~ /^password=(.*)/);
+
+ $log->log_debug("password [$password]");
+ $log->log_debug("web_password [" . $cf->web_password() . "]");
+
+ if($cf->web_password() eq $password){
+ my $s = $sm->add($ci->user_agent(), $ci->serial_key());
+ my $view = new Keitairc::View($cf, $ci, $s->{id});
+ if ($ci->is_webkit() && $cf->webkit_newui()) {
+ return add_cookie($view->redirect('/'), $s->{id});
+ } else {
+ return $view->redirect("/$s->{id}/index");
+ }
+ }
-################################################################
-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);
+ # password mismatch
+ my $view = new Keitairc::View($cf, $ci);
+ return $view->redirect('/');
}
################################################################
-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);
+sub action_error {
+ my $request = shift;
+ my $error_code = shift;
+ my $ci = new Keitairc::ClientInfo($request);
+ my $view = new Keitairc::View($cf, $ci);
+ return $view->render('error.html', { action => $request->uri(),
+ _http_status_code => $error_code,
+ _http_status_message => status_message($error_code) });
}
################################################################
-# $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{
- 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 action_public {
+ my $request = shift;
+ my $uri = shift; # such as '/favicon.ico'
+ my $ci = new Keitairc::ClientInfo($request);
+ my $view = new Keitairc::View($cf, $ci);
+ return $view->public($request, $uri);
}
################################################################
-sub now{
- my ($sec,$min,$hour) = localtime(time);
- sprintf('%02d:%02d', $hour, $min);
-}
+# かんたんログインのPOST先
+# DoCoMoだったらiccが来ているはずなので, icc + user_agent でチェック。
+# 合っていたらセッション復帰して /{SESSION}/index へ
+sub action_login_icc{
+ my $request = shift;
+ my $ci = new Keitairc::ClientInfo($request);
+ if($ci->is_docomo()){
+ my $docomo_foma_icc = $ci->docomo_foma_icc();
+ if(length $docomo_foma_icc){
+ if(my $s = $sm->verify({serial_key => $docomo_foma_icc,
+ user_agent => $ci->user_agent()})){
+ $log->log_debug("redirect to /$s->{id}/index from docomo_foma_icc");
+ my $view = new Keitairc::View($cf, $ci, $s->{id});
+ return $view->redirect("/$s->{id}/index");
+ }
+
+ if($docomo_foma_icc eq $cf->docomo_foma_icc()){
+ my $s = $sm->add($ci->user_agent(), $docomo_foma_icc);
+ $log->log_debug("redirect to /$s->{id}/index from docomo_foma_icc");
+ my $view = new Keitairc::View($cf, $ci, $s->{id});
+ return $view->redirect("/$s->{id}/index");
+ }
+
+ my $view = new Keitairc::View($cf, $ci);
+ return $view->render('login_icc.html', { icc => $docomo_foma_icc });
+ }
+ }
-################################################################
-sub escape{
- local($_) = shift;
- s/&/&/g;
- s/>/>/g;
- s/</</g;
- $_;
+ my $view = new Keitairc::View($cf, $ci);
+ return $view->render('root.html', {
+ docomo_foma_icc => $cf->docomo_foma_icc(),
+ docomo_imodeid => $cf->docomo_imodeid(),
+ });
}
################################################################
-sub label{
- my $accesskey = shift;
-
- if($accesskey < 10){
- sprintf('%d ', $accesskey);
- }else{
- ' ';
- }
+# かんたんログインのPOST先
+# DoCoMoだったらiモードIDが来ているはずなので, iモードID + user_agent でチェック。
+# 合っていたらセッション復帰して /{SESSION}/index へ
+sub action_login_imodeid{
+ my $request = shift;
+ my $ci = new Keitairc::ClientInfo($request);
+ if($ci->is_docomo()){
+ my $docomo_imodeid = $ci->docomo_imodeid();
+ if(length $docomo_imodeid){
+ if(my $s = $sm->verify({serial_key => $docomo_imodeid,
+ user_agent => $ci->user_agent()})){
+ $log->log_debug("redirect to /$s->{id}/index from docomo_imodeid");
+ my $view = new Keitairc::View($cf, $ci, $s->{id});
+ return $view->redirect("/$s->{id}/index");
+ }
+
+ if($docomo_imodeid eq $cf->docomo_imodeid()){
+ my $s = $sm->add($ci->user_agent(), $docomo_imodeid);
+ $log->log_debug("redirect to /$s->{id}/index from docomo_imodeid");
+ my $view = new Keitairc::View($cf, $ci, $s->{id});
+ return $view->redirect("/$s->{id}/index");
+ }
+
+ my $view = new Keitairc::View($cf, $ci);
+ return $view->render('login_imodeid.html', { imodeid => $docomo_imodeid });
+ }
+ }
+
+ my $view = new Keitairc::View($cf, $ci);
+ return $view->render('root.html', {
+ docomo_foma_icc => $cf->docomo_foma_icc(),
+ docomo_imodeid => $cf->docomo_imodeid(),
+ });
}
################################################################
-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));
+sub action_root{
+ my $request = shift;
+ my $ci = new Keitairc::ClientInfo($request);
+
+ if($ci->cookie_available()){
+ my $session_id = $ci->{cookie}->{sid};
+ if(defined($session_id) && length($session_id)){
+ if($sm->verify({session_id => $session_id,
+ user_agent => $ci->user_agent()})){
+ $log->log_debug("redirect to /$session_id/index from cookie");
+ my $view = new Keitairc::View($cf, $ci, $session_id);
+ if ($ci->is_webkit() && $cf->webkit_newui()) {
+ return add_cookie($view->render('root_home.html', {sid => $session_id}), $session_id);
+ } else {
+ return $view->redirect("/$session_id/index");
+ }
+ }
+ }
}
- $accesskey++;
-
- # \e$BL$FI9T?t\e(B
- if($unread_lines{$canon_channel}){
- $buf .= sprintf(' <a href="%s%s,recent">%s</a>',
- $docroot,
- uri_escape($channel),
- $unread_lines{$canon_channel});
+ if($ci->is_ezweb()){
+ my $subscriber_id = $ci->au_subscriber_id();
+ if(length $subscriber_id){
+ if(my $s = $sm->verify({serial_key => $subscriber_id,
+ user_agent => $ci->user_agent()})){
+ $log->log_debug("redirect to /$s->{id}/index from subscriber_id");
+ my $view = new Keitairc::View($cf, $ci, $s->{id});
+ return $view->redirect("/$s->{id}/index");
+ }
+
+ if($subscriber_id eq $cf->au_subscriber_id()){
+ my $s = $sm->add($ci->user_agent(), $subscriber_id);
+ $log->log_debug("redirect to /$s->{id}/index from au_subscriber_id");
+ my $view = new Keitairc::View($cf, $ci, $s->{id});
+ return $view->redirect("/$s->{id}/index");
+ }
+ }
}
- $buf .= '<br>';
- }
- $buf .= qq(0 <a href="$docroot" accesskey="0">refresh list</a><br>);
+ if($ci->is_softbank()){
+ my $serial_key = $ci->softbank_serial();
+ if(length $serial_key){
+ if(my $s = $sm->verify({serial_key => $serial_key,
+ user_agent => $ci->user_agent()})){
+ $log->log_debug("redirect to /$s->{id}/index from softbank serial_key");
+ my $view = new Keitairc::View($cf, $ci, $s->{id});
+ return $view->redirect("/$s->{id}/index");
+ }
+ if($serial_key eq $cf->softbank_serial_key()){
+ my $s = $sm->add($ci->user_agent(), $serial_key);
+ $log->log_debug("redirect to /$s->{id}/index from softbank_serial_key");
+ my $view = new Keitairc::View($cf, $ci, $s->{id});
+ return $view->redirect("/$s->{id}/index");
+ }
+ }
+ }
- if(grep($unread_lines{$_}, keys %unread_lines)){
- $buf .= qq(* <a href="$docroot,recent" accesskey="*">recent</a><br>);
- }
+ if($ci->is_emobile()){
+ my $userid = $ci->emobile_userid();
+ if(length $userid){
+ if(my $s = $sm->verify({serial_key => $userid,
+ user_agent => $ci->user_agent()})){
+ $log->log_debug("redirect to /$s->{id}/index from userid");
+ my $view = new Keitairc::View($cf, $ci, $s->{id});
+ return $view->redirect("/$s->{id}/index");
+ }
+
+ if($userid eq $cf->emobile_userid()){
+ my $s = $sm->add($ci->user_agent(), $userid);
+ $log->log_debug("redirect to /$s->{id}/index from emobile_userid");
+ my $view = new Keitairc::View($cf, $ci, $s->{id});
+ return $view->redirect("/$s->{id}/index");
+ }
+ }
+ }
- $buf .= qq( - keitairc $version);
- $buf;
+ my $view = new Keitairc::View($cf, $ci);
+ return $view->render('root.html', {
+ docomo_foma_icc => $cf->docomo_foma_icc(),
+ docomo_imodeid => $cf->docomo_imodeid(),
+ });
}
################################################################
-# \e$B%A%c%M%kL>>N$rC;$+$/$9$k\e(B
-sub compact_channel_name{
- local($_) = shift;
-
- # #name:*.jp \e$B$r\e(B %name \e$B$K\e(B
- if(s/:\*\.jp$//){
- s/^#/%/;
- }
-
- # \e$BKvHx$NC1FH$N\e(B @ \e$B$O<h$k\e(B (for multicast.plm)
- s/\@$//;
-
- $_;
+sub action_redirect_root{
+ my $request = shift;
+ my $ci = new Keitairc::ClientInfo($request);
+ my $view = new Keitairc::View($cf, $ci);
+ return $view->redirect('/');
}
################################################################
-sub canon_name{
- local($_) = shift;
+sub parse_message{
+ my $request = shift;
+ my $ci = new Keitairc::ClientInfo($request);
+ my $timestamp;
- tr/A-Z[\\]^/a-z{|}~/;
+ my $message = $request->content();
- $_;
-}
-
-################################################################
-sub render{
- local($_);
- my @buf;
-
- my @src = (reverse(split("\n", shift)))[0 .. $config->web_lines];
+ if(length($message)){
+ ($message, $timestamp) = split(/&/, $message);
- for (@src){
- next unless defined;
- next unless length;
+ $timestamp =~ s/^stamp=//g;
- $_ = &escape($_);
+ $message =~ s/^m=//;
+ $message =~ s/\+/ /g;
+ $message = uri_unescape($message);
- 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){
- # 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;
+ if($ci->is_webkit() && !$cf->webkit_newui()){
+ $message = fix_webkit_escape($message);
}
- }
}
+ if ($cf->webkit_newui()) {
+ # ajax で投げ込んでるので utf8 できます
+ $message = Encode::decode('utf8', $message);
+ } else {
+ $message = Encode::decode($cf->web_charset(), $message);
+ }
+ return ($message, $timestamp);
+}
- s/\s+$//;
- s/\s+/ /g;
- push @buf, $_;
- }
+sub send_message{
+ my $request = shift;
+ my $channel = shift;
- '<pre>' . join("\n", @buf) . '</pre>';
-}
+ my ($message, $timestamp) = parse_message($request);
-################################################################
-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;
- }
+ if(length($message) && length($channel)){
+ if($ib->update_timestamp($timestamp)){
+ my $enc_message = Encode::encode($cf->irc_charset(), $message);
+ my $enc_channel = Encode::encode($cf->irc_charset(), $channel);
+ $irc->yield(privmsg => $enc_channel => $enc_message);
+ my $cid = $ib->name2cid($channel);
+ $ib->add_message($cid, $message, $cf->irc_nick());
+ }
}
- }
- }
+}
- my $uri = $request->uri;
- my $content = '<html><head>';
- $content .= '<meta http-equiv="Cache-Control" content="max-age=0" />';
+sub send_command{
+ my $request = shift;
- # POST \e$B$5$l$F$-$?$b$N$OH/8@\e(B
- if($request->method =~ /POST/i){
- my $message = $request->content;
- $message =~ s/^m=//;
- $message =~ s/\+/ /g;
- $message = uri_unescape($message);
+ my ($message, $timestamp) = parse_message($request);
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>);
- }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});
+ if($message =~ s|^/||) {
+ my ($params, $trailing) = split(/ :/, $message, 2);
+ my @postcmd = split(/ /, $params);
+ push @postcmd, $trailing if defined $trailing;
+ # This parser may be incomplete.
+ if($postcmd[0] =~ /join/i) {
+ if($postcmd[1] =~ /^\w/) {
+ $ib->join($postcmd[1]);
+ return;
+ }
+ } elsif($postcmd[0] =~ /part/i) {
+ if($postcmd[1] =~ /^\w/) {
+ $ib->part($ib->name2cid($postcmd[1]));
+ return;
+ }
+ }
+ $irc->yield(map { Encode::encode($cf->irc_charset(), $_) } @postcmd);
}
- $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');
+################################################################
+# posted string from Webkit browser
+# contains escaped utf-8 in the form %uXXXX
+# and may contains escaped Shift-JIS (web_charset) in the form \xXX
+# when operated from Safari/Mac OS X
+sub fix_webkit_escape{
+ # charset: $cf->irc_charset()
+ my $in = shift;
+ $in =~ s/\\x([0-9A-F]{2})/pack('C',hex($1))/egi;
+ #my $pi = Encode::decode('utf8', $in);
+ $in =~ s/%u([0-9A-F]{4})/pack('U',hex($1))/egi;
+ return $in;
}
__END__
OSDN Git Service
