keitairc

   1 #!/usr/bin/perl
   2 # -*- mode: perl; coding: utf-8 -*-
   3 # keitairc
   4 #
   5 # Copyright (c) 2003-2010 Jun Morimoto <morimoto@mrmt.net>
   6 # This program is covered by the GNU General Public License 2
   7 #
   8 # Depends: libpoe-component-irc-perl,
   9 #   liburi-perl, libwww-perl, libappconfig-perl, libproc-daemon-perl,
  10 #   libhtml-template-perl
  11 #
  12 # 00location_receiver plugin use XML::Simple, so if you want to use it
  13 #    Depends: libxml-simple-perl
  14
  15 use Encode;
  16 use POE;
  17 use POE::Filter::HTTPD;
  18 use POE::Component::IRC;
  19 use POE::Component::Server::TCP;
  20 use URI::Escape;
  21 use HTML::Template;
  22 use HTTP::Response;
  23 use HTTP::Status;
  24
  25 use FindBin;
  26 use lib ("$FindBin::Bin/lib", '/usr/share/keitairc/lib');
  27 use Keitairc::Config;
  28 use Keitairc::View;
  29 use Keitairc::IrcBuffer;
  30 use Keitairc::IrcCallback;
  31 use Keitairc::ClientInfo;
  32 use Keitairc::SessionManager;
  33 use Keitairc::Plugins;
  34 use Keitairc::Log;
  35 use strict;
  36 use warnings;
  37
  38 our $cf = new Keitairc::Config({version => '2.1a1', argv => \@ARGV});
  39 our $ib = new Keitairc::IrcBuffer({history => $cf->web_lines()});
  40 our $sm = new Keitairc::SessionManager({default_ttl => $cf->session_ttl()});
  41 our $pl = new Keitairc::Plugins({config => $cf});
  42
  43 # daemonize
  44 if($cf->daemonize()){
  45         use Proc::Daemon;
  46
  47         Proc::Daemon::Init;
  48         if(length $cf->pid_dir()){
  49                 if (open(PID, '> ' . $cf->pid_dir() . '/' . $cf->pid_file())) {
  50                         print PID $$, "\n";
  51                         close(PID);
  52                 }
  53         }
  54         $poe_kernel->has_forked if ($poe_kernel->can('has_forked'));
  55 }
  56
  57 # create irc component
  58 our $irc = POE::Component::IRC->spawn(
  59         Alias => 'keitairc_irc',
  60         Nick => $cf->irc_nick(),
  61         Username => $cf->irc_username(),
  62         Ircname => $cf->irc_desc(),
  63         Server => $cf->irc_server(),
  64         Port => $cf->irc_port(),
  65         Password => $cf->irc_password());
  66
  67 # create POE session
  68 POE::Session->create(
  69         heap => {
  70                 seen_traffic => 0,
  71                 disconnect_msg => 1,
  72                 Config => $cf,
  73                 Irc => $irc,
  74                 IrcBuffer => $ib,
  75         },
  76         inline_states => {
  77                 _start => \&Keitairc::IrcCallback::irc_start,
  78                 autoping => \&Keitairc::IrcCallback::irc_autoping,
  79                 connect => \&Keitairc::IrcCallback::irc_connect,
  80                 irc_registered => \&Keitairc::IrcCallback::irc_registered,
  81                 irc_001 => \&Keitairc::IrcCallback::irc_001,
  82                 irc_join => \&Keitairc::IrcCallback::irc_join,
  83                 irc_part => \&Keitairc::IrcCallback::irc_part,
  84                 irc_quit => \&Keitairc::IrcCallback::irc_quit,
  85                 irc_public => \&Keitairc::IrcCallback::irc_public,
  86                 irc_notice => \&Keitairc::IrcCallback::irc_notice,
  87                 irc_mode => \&Keitairc::IrcCallback::irc_mode,
  88                 irc_nick => \&Keitairc::IrcCallback::irc_nick,
  89                 irc_msg => \&Keitairc::IrcCallback::irc_msg,
  90                 irc_topic => \&Keitairc::IrcCallback::irc_topic,
  91                 irc_332 => \&Keitairc::IrcCallback::irc_topicraw,
  92                 irc_352 => \&Keitairc::IrcCallback::irc_whoreply,
  93                 irc_ctcp_action => \&Keitairc::IrcCallback::irc_ctcp_action,
  94                 irc_disconnected => \&Keitairc::IrcCallback::irc_reconnect,
  95                 irc_error => \&Keitairc::IrcCallback::irc_reconnect,
  96                 irc_socketerr => \&Keitairc::IrcCallback::irc_reconnect,
  97         });
  98
  99 # create web server component
 100 POE::Component::Server::TCP->new(
 101         Alias => 'keitairc',
 102         Port => $cf->web_listen_port(),
 103         ClientFilter => 'POE::Filter::HTTPD',
 104         ClientInput => \&http_request);
 105
 106 # fire up main loop
 107 $poe_kernel->run();
 108 exit 0;
 109
 110 ################################################################
 111 sub http_request{
 112         my ($kernel, $heap, $request) = @_[KERNEL, HEAP, ARG0];
 113
 114         # Filter::HTTPD sometimes generates HTTP::Response objects.
 115         # They indicate (and contain the response for) errors that occur
 116         # while parsing the client's HTTP request.  It's easiest to send
 117         # the responses as they are and finish up.
 118         if($request->isa('HTTP::Response')){
 119                 $heap->{client}->put($request);
 120         }elsif(my $response = dispatch($request)){
 121                 $heap->{client}->put($response);
 122         }
 123
 124         $kernel->yield('shutdown');
 125 }
 126
 127 ################################################################
 128 sub dispatch{
 129         my $request = shift;
 130         my $uri = $request->uri();
 131         my $ci = new Keitairc::ClientInfo($request);
 132
 133         Keitairc::Log::log_debug("dispatch: $uri");
 134
 135         {
 136                 # chop off $cf->web_root()
 137                 my $root = $cf->web_root();
 138                 $uri =~ s|$root|/|;
 139         }
 140
 141         if($uri eq '/'){
 142                 return action_root($request);
 143         }
 144
 145         if($uri eq '/login'){
 146                 return action_login($request);
 147         }
 148
 149         if($uri eq '/login_icc'){
 150                 return action_login_icc($request);
 151         }
 152
 153         if($uri eq '/login_imodeid?guid=ON'){
 154                 return action_login_imodeid($request);
 155         }
 156
 157         for my $name ($pl->list_action_plugins()){
 158                 if($uri =~ m|^/(S[a-zA-Z]{10})/$name/(.*)| ||
 159                    $uri =~ m|^/(S[a-zA-Z]{10})/$name$|){
 160                         if($sm->verify({session_id => $1, user_agent => $ci->user_agent()})){
 161                                 return add_cookie($pl->{plugins}->{$name}->{action_imprementation}($request, $name, $1, $2), $1);
 162                         }
 163                         if ($ci->is_webkit() && $cf->webkit_newui()) {
 164                                 return action_error($request, 401);
 165                         } else {
 166                                 return action_redirect_root($request);
 167                         }
 168                 }
 169         }
 170
 171         return action_public($request, $uri) || action_error($request, 404);
 172 }
 173
 174 ################################################################
 175 # adds session id cookie to http response object
 176 sub add_cookie{
 177         my $response = shift;
 178         my $session_id = shift;
 179
 180         my ($sec, $min, $hour, $mday, $mon, $year, $wday) = localtime(time + $cf->cookie_ttl());
 181         my $expiration =
 182                 sprintf('%.3s, %.2d-%.3s-%.4s %.2d:%.2d:%.2d',
 183                         qw(Sun Mon Tue Wed Thu Fri Sat)[$wday],
 184                         $mday,
 185                         qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)[$mon],
 186                         $year + 1900,
 187                         $hour,
 188                         $min,
 189                         $sec);
 190         my $content = sprintf("sid=%s; expires=%s; path=%s; \n", $session_id, $expiration, $cf->web_root());
 191         $response->push_header('Set-Cookie', $content);
 192         $response;
 193 }
 194
 195 ################################################################
 196 # 通常ログインのPOST先
 197 # パスワードをチェックして
 198 # 間違っていたら / へリンクして終わり
 199 # 合っていたらセッションを発行し /{SESSION}/index へ
 200 sub action_login{
 201         my $request = shift;
 202         my $ci = new Keitairc::ClientInfo($request);
 203         my $content = $request->decoded_content();
 204         my ($password) = ($content =~ /^password=(.*)/);
 205
 206         Keitairc::Log::log_debug("password [$password]");
 207         Keitairc::Log::log_debug("web_password [" . $cf->web_password() . "]");
 208
 209         if($cf->web_password() eq $password){
 210                 my $s = $sm->add($ci->user_agent(), $ci->serial_key());
 211                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 212                 if ($ci->is_webkit() && $cf->webkit_newui()) {
 213                         return add_cookie($view->redirect('/'), $s->{id});
 214                 } else {
 215                         return $view->redirect("/$s->{id}/index");
 216                 }
 217         }
 218
 219         # password mismatch
 220         my $view = new Keitairc::View($cf, $ci);
 221         return $view->redirect('/');
 222 }
 223
 224 ################################################################
 225 sub action_error {
 226         my $request = shift;
 227         my $error_code = shift;
 228         my $ci = new Keitairc::ClientInfo($request);
 229         my $view = new Keitairc::View($cf, $ci);
 230         return $view->render('error.html', { action => $request->uri(),
 231                                              _http_status_code => $error_code,
 232                                              _http_status_message => status_message($error_code) });
 233 }
 234
 235 ################################################################
 236 sub action_public{
 237         my $request = shift;
 238         my $uri = shift;        # such as '/favicon.ico'
 239         my $ci = new Keitairc::ClientInfo($request);
 240         my $view = new Keitairc::View($cf, $ci);
 241         return $view->public($uri);
 242 }
 243
 244 ################################################################
 245 # かんたんログインのPOST先
 246 # DoCoMoだったらiccが来ているはずなので, icc + user_agent でチェック。
 247 # 合っていたらセッション復帰して /{SESSION}/index へ
 248 sub action_login_icc{
 249         my $request = shift;
 250         my $ci = new Keitairc::ClientInfo($request);
 251         if($ci->is_docomo()){
 252                 my $docomo_foma_icc = $ci->docomo_foma_icc();
 253                 if(length $docomo_foma_icc){
 254                         if(my $s = $sm->verify({serial_key => $docomo_foma_icc,
 255                                                 user_agent => $ci->user_agent()})){
 256                                 Keitairc::Log::log_debug("redirect to /$s->{id}/index from docomo_foma_icc");
 257                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 258                                 return $view->redirect("/$s->{id}/index");
 259                         }
 260
 261                         if($docomo_foma_icc eq $cf->docomo_foma_icc()){
 262                                 my $s = $sm->add($ci->user_agent(), $docomo_foma_icc);
 263                                 Keitairc::Log::log_debug("redirect to /$s->{id}/index from docomo_foma_icc");
 264                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 265                                 return $view->redirect("/$s->{id}/index");
 266                         }
 267
 268                         my $view = new Keitairc::View($cf, $ci);
 269                         return $view->render('login_icc.html', { icc => $docomo_foma_icc });
 270                 }
 271         }
 272
 273         my $view = new Keitairc::View($cf, $ci);
 274         return $view->render('root.html', {
 275                 docomo_foma_icc => $cf->docomo_foma_icc(),
 276                 docomo_imodeid => $cf->docomo_imodeid(),
 277                         });
 278 }
 279
 280 ################################################################
 281 # かんたんログインのPOST先
 282 # DoCoMoだったらiモードIDが来ているはずなので, iモードID + user_agent でチェック。
 283 # 合っていたらセッション復帰して /{SESSION}/index へ
 284 sub action_login_imodeid{
 285         my $request = shift;
 286         my $ci = new Keitairc::ClientInfo($request);
 287         if($ci->is_docomo()){
 288                 my $docomo_imodeid = $ci->docomo_imodeid();
 289                 if(length $docomo_imodeid){
 290                         if(my $s = $sm->verify({serial_key => $docomo_imodeid,
 291                                                 user_agent => $ci->user_agent()})){
 292                                 Keitairc::Log::log_debug("redirect to /$s->{id}/index from docomo_imodeid");
 293                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 294                                 return $view->redirect("/$s->{id}/index");
 295                         }
 296
 297                         if($docomo_imodeid eq $cf->docomo_imodeid()){
 298                                 my $s = $sm->add($ci->user_agent(), $docomo_imodeid);
 299                                 Keitairc::Log::log_debug("redirect to /$s->{id}/index from docomo_imodeid");
 300                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 301                                 return $view->redirect("/$s->{id}/index");
 302                         }
 303
 304                         my $view = new Keitairc::View($cf, $ci);
 305                         return $view->render('login_imodeid.html', { imodeid => $docomo_imodeid });
 306                 }
 307         }
 308
 309         my $view = new Keitairc::View($cf, $ci);
 310         return $view->render('root.html', {
 311                 docomo_foma_icc => $cf->docomo_foma_icc(),
 312                 docomo_imodeid => $cf->docomo_imodeid(),
 313                         });
 314 }
 315
 316 ################################################################
 317 sub action_root{
 318         my $request = shift;
 319         my $ci = new Keitairc::ClientInfo($request);
 320
 321         if($ci->cookie_available()){
 322                 my $session_id = $ci->{cookie}->{sid};
 323                 if(defined($session_id) && length($session_id)){
 324                         if($sm->verify({session_id => $session_id,
 325                                         user_agent => $ci->user_agent()})){
 326                                 Keitairc::Log::log_debug("redirect to /$session_id/index from cookie");
 327                                 my $view = new Keitairc::View($cf, $ci, $session_id);
 328                                 if ($ci->is_webkit() && $cf->webkit_newui()) {
 329                                         return add_cookie($view->render('root_home.html', {sid => $session_id}), $session_id);
 330                                 } else {
 331                                         return $view->redirect("/$session_id/index");
 332                                 }
 333                         }
 334                 }
 335         }
 336
 337         if($ci->is_ezweb()){
 338                 my $subscriber_id = $ci->au_subscriber_id();
 339                 if(length $subscriber_id){
 340                         if(my $s = $sm->verify({serial_key => $subscriber_id,
 341                                                 user_agent => $ci->user_agent()})){
 342                                 Keitairc::Log::log_debug("redirect to /$s->{id}/index from subscriber_id");
 343                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 344                                 return $view->redirect("/$s->{id}/index");
 345                         }
 346
 347                         if($subscriber_id eq $cf->au_subscriber_id()){
 348                                 my $s = $sm->add($ci->user_agent(), $subscriber_id);
 349                                 Keitairc::Log::log_debug("redirect to /$s->{id}/index from au_subscriber_id");
 350                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 351                                 return $view->redirect("/$s->{id}/index");
 352                         }
 353                 }
 354         }
 355
 356         if($ci->is_softbank()){
 357                 my $serial_key = $ci->softbank_serial();
 358                 if(length $serial_key){
 359                         if(my $s = $sm->verify({serial_key => $serial_key,
 360                                                 user_agent => $ci->user_agent()})){
 361                                 Keitairc::Log::log_debug("redirect to /$s->{id}/index from softbank serial_key");
 362                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 363                                 return $view->redirect("/$s->{id}/index");
 364                         }
 365                         if($serial_key eq $cf->softbank_serial_key()){
 366                                 my $s = $sm->add($ci->user_agent(), $serial_key);
 367                                 Keitairc::Log::log_debug("redirect to /$s->{id}/index from softbank_serial_key");
 368                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 369                                 return $view->redirect("/$s->{id}/index");
 370                         }
 371                 }
 372         }
 373
 374         if($ci->is_emobile()){
 375                 my $userid = $ci->emobile_userid();
 376                 if(length $userid){
 377                         if(my $s = $sm->verify({serial_key => $userid,
 378                                                 user_agent => $ci->user_agent()})){
 379                                 Keitairc::Log::log_debug("redirect to /$s->{id}/index from userid");
 380                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 381                                 return $view->redirect("/$s->{id}/index");
 382                         }
 383
 384                         if($userid eq $cf->emobile_userid()){
 385                                 my $s = $sm->add($ci->user_agent(), $userid);
 386                                 Keitairc::Log::log_debug("redirect to /$s->{id}/index from emobile_userid");
 387                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 388                                 return $view->redirect("/$s->{id}/index");
 389                         }
 390                 }
 391         }
 392
 393         my $view = new Keitairc::View($cf, $ci);
 394         return $view->render('root.html', {
 395                 docomo_foma_icc => $cf->docomo_foma_icc(),
 396                 docomo_imodeid => $cf->docomo_imodeid(),
 397                         });
 398 }
 399
 400 ################################################################
 401 sub action_redirect_root{
 402         my $request = shift;
 403         my $ci = new Keitairc::ClientInfo($request);
 404         my $view = new Keitairc::View($cf, $ci);
 405         return $view->redirect('/');
 406 }
 407
 408 ################################################################
 409 sub parse_message{
 410         my $request = shift;
 411         my $ci = new Keitairc::ClientInfo($request);
 412         my $timestamp;
 413
 414         my $message = $request->content();
 415
 416         if(length($message)){
 417                 ($message, $timestamp) = split(/&/, $message);
 418
 419                 $timestamp =~ s/^stamp=//g;
 420
 421                 $message =~ s/^m=//;
 422                 $message =~ s/\+/ /g;
 423                 $message = uri_unescape($message);
 424
 425                 if($ci->is_webkit() && !$cf->webkit_newui()){
 426                         $message = fix_webkit_escape($message);
 427                 }
 428         }
 429         if ($cf->webkit_newui()) {
 430                 # ajax で投げ込んでるので utf8 できます
 431                 $message = Encode::decode('utf8', $message);
 432         } else {
 433                 $message = Encode::decode($cf->web_charset(), $message);
 434         }
 435         return ($message, $timestamp);
 436 }
 437
 438 sub send_message{
 439         my $request = shift;
 440         my $channel = shift;
 441
 442         my ($message, $timestamp) = parse_message($request);
 443
 444         if(length($message) && length($channel)){
 445                 if($ib->update_timestamp($timestamp)){
 446                         my $enc_message = Encode::encode($cf->irc_charset(), $message);
 447                         my $enc_channel = Encode::encode($cf->irc_charset(), $channel);
 448                         $irc->yield(privmsg => $enc_channel => $enc_message);
 449                         my $cid = $ib->name2cid($channel);
 450                         $ib->add_message($cid, $message, $cf->irc_nick());
 451                 }
 452         }
 453 }
 454
 455 sub send_command{
 456         my $request = shift;
 457
 458         my ($message, $timestamp) = parse_message($request);
 459
 460         if(length($message)){
 461                 if($message =~ s|^/||) {
 462                         my ($params, $trailing) = split(/ :/, $message, 2);
 463                         my @postcmd = split(/ /, $params);
 464                         push @postcmd, $trailing if defined $trailing;
 465                         # This parser may be incomplete.
 466                         if($postcmd[0] =~ /join/i) {
 467                                 if($postcmd[1] =~ /^\w/) {
 468                                         $ib->join($postcmd[1]);
 469                                         return;
 470                                 }
 471                         } elsif($postcmd[0] =~ /part/i) {
 472                                 if($postcmd[1] =~ /^\w/) {
 473                                         $ib->part($ib->name2cid($postcmd[1]));
 474                                         return;
 475                                 }
 476                         }
 477                         $irc->yield(map { Encode::encode($cf->irc_charset(), $_) } @postcmd);
 478                 }
 479         }
 480 }
 481
 482 ################################################################
 483 # posted string from Webkit browser
 484 # contains escaped utf-8 in the form %uXXXX
 485 # and may contains escaped Shift-JIS (web_charset) in the form \xXX
 486 # when operated from Safari/Mac OS X
 487 sub fix_webkit_escape{
 488         # charset: $cf->irc_charset()
 489         my $in = shift;
 490         $in =~ s/\\x([0-9A-F]{2})/pack('C',hex($1))/egi;
 491         #my $pi = Encode::decode('utf8', $in);
 492         $in =~ s/%u([0-9A-F]{4})/pack('U',hex($1))/egi;
 493         return $in;
 494 }
 495
 496 __END__