keitairc

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