keitairc

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