keitairc

   1 #!/usr/bin/perl
   2 # keitairc
   3 # $Id: keitairc,v 1.44 2008-02-26 00:41:09 morimoto 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 use lib qw(lib /usr/share/keitairc/lib);
  14 use strict;
  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 Proc::Daemon;
  24 use Keitairc::Config;
  25 use Keitairc::View;
  26 use Keitairc::IrcBuffer;
  27 use Keitairc::IrcCallback;
  28 use Keitairc::ClientInfo;
  29 use Keitairc::SessionManager;
  30 use Keitairc::Plugins;
  31
  32 our $cf = new Keitairc::Config('2.0b5', @ARGV);
  33 our $ib = new Keitairc::IrcBuffer({history => $cf->web_lines()});
  34 our $sm = new Keitairc::SessionManager({default_ttl => $cf->session_ttl()});
  35 our $pl = new Keitairc::Plugins({config => $cf});
  36
  37 # daemonize
  38 if($cf->daemonize()){
  39         Proc::Daemon::Init;
  40         if(length $cf->pid_dir()){
  41                 if (open(PID, '> ' . $cf->pid_dir() . '/keitairc.pid')) {
  42                         print PID $$, "\n";
  43                         close(PID);
  44                 }
  45         }
  46 }
  47
  48 # create irc component
  49 our $irc = POE::Component::IRC->spawn(
  50         Alias => 'keitairc_irc',
  51         Nick => $cf->irc_nick(),
  52         Username => $cf->irc_username(),
  53         Ircname => $cf->irc_desc(),
  54         Server => $cf->irc_server(),
  55         Port => $cf->irc_port(),
  56         Password => $cf->irc_password());
  57
  58 # create POE session
  59 POE::Session->create(
  60         heap => {
  61                 seen_traffic => 0,
  62                 disconnect_msg => 1,
  63                 Config => $cf,
  64                 Irc => $irc,
  65                 IrcBuffer => $ib,
  66         },
  67         inline_states => {
  68                 _start => \&Keitairc::IrcCallback::irc_start,
  69                 autoping => \&Keitairc::IrcCallback::irc_autoping,
  70                 connect => \&Keitairc::IrcCallback::irc_connect,
  71                 irc_001 => \&Keitairc::IrcCallback::irc_001,
  72                 irc_join => \&Keitairc::IrcCallback::irc_join,
  73                 irc_part => \&Keitairc::IrcCallback::irc_part,
  74                 irc_public => \&Keitairc::IrcCallback::irc_public,
  75                 irc_notice => \&Keitairc::IrcCallback::irc_notice,
  76                 irc_mode => \&Keitairc::IrcCallback::irc_mode,
  77                 irc_msg => \&Keitairc::IrcCallback::irc_msg,
  78                 irc_topic => \&Keitairc::IrcCallback::irc_topic,
  79                 irc_332 => \&Keitairc::IrcCallback::irc_topicraw,
  80                 irc_352 => \&Keitairc::IrcCallback::irc_whoreply,
  81                 irc_ctcp_action => \&Keitairc::IrcCallback::irc_ctcp_action,
  82                 irc_disconnected => \&Keitairc::IrcCallback::irc_reconnect,
  83                 irc_error => \&Keitairc::IrcCallback::irc_reconnect,
  84                 irc_socketerr => \&Keitairc::IrcCallback::irc_reconnect,
  85         });
  86
  87 # create web server component
  88 POE::Component::Server::TCP->new(
  89         Alias => 'keitairc',
  90         Port => $cf->web_port(),
  91         ClientFilter => 'POE::Filter::HTTPD',
  92         ClientInput => \&http_request);
  93
  94 # fire up main loop
  95 $poe_kernel->run();
  96 exit 0;
  97
  98 ################################################################
  99 sub http_request{
 100         my ($kernel, $heap, $request) = @_[KERNEL, HEAP, ARG0];
 101
 102         # Filter::HTTPD sometimes generates HTTP::Response objects.
 103         # They indicate (and contain the response for) errors that occur
 104         # while parsing the client's HTTP request.  It's easiest to send
 105         # the responses as they are and finish up.
 106         if($request->isa('HTTP::Response')){
 107                 $heap->{client}->put($request);
 108         }elsif(my $response = dispatch($request)){
 109                 $heap->{client}->put($response);
 110         }
 111
 112         $kernel->yield('shutdown');
 113 }
 114
 115 ################################################################
 116 sub dispatch{
 117         my $request = shift;
 118         my $uri = $request->uri();
 119         my $ci = new Keitairc::ClientInfo($request);
 120
 121         ::log_debug("dispatch: $uri");
 122
 123         {
 124                 # chop off $cf->web_root()
 125                 my $root = $cf->web_root();
 126                 $uri =~ s|$root|/|;
 127         }
 128
 129         if($uri eq '/'){
 130                 return action_root($request);
 131         }
 132
 133         if($uri eq '/login'){
 134                 return action_login($request);
 135         }
 136
 137         if($uri eq '/login_icc'){
 138                 return action_login_icc($request);
 139         }
 140
 141         if($uri eq '/robots.txt'){
 142                 return action_robots_txt($request);
 143         }
 144
 145         for my $name ($pl->list_action_plugins()){
 146                 if($uri =~ m|^/(S[a-zA-Z]{10})/$name/(.*)| ||
 147                    $uri =~ m|^/(S[a-zA-Z]{10})/$name$|){
 148                         if($sm->verify({session_id => $1, user_agent => $ci->user_agent()})){
 149                                 return add_cookie($pl->{plugins}->{$name}->{action_imprementation}($request, $name, $1, $2), $1);
 150                         }
 151                         return action_redirect_root($request);
 152                 }
 153         }
 154
 155         ::log("dispatch: don't know how to dispatch uri[$uri]");
 156         return action_404($request);
 157 }
 158
 159 ################################################################
 160 # adds session id cookie to http response object
 161 sub add_cookie{
 162         my $response = shift;
 163         my $session_id = shift;
 164
 165         my ($sec, $min, $hour, $mday, $mon, $year, $wday) = localtime(time + $cf->cookie_ttl());
 166         my $expiration =
 167                 sprintf('%.3s, %.2d-%.3s-%.4s %.2d:%.2d:%.2d',
 168                         qw(Sun Mon Tue Wed Thu Fri Sat)[$wday],
 169                         $mday,
 170                         qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)[$mon],
 171                         $year + 1900,
 172                         $hour,
 173                         $min,
 174                         $sec);
 175         my $content = sprintf("sid=%s; expires=%s; \n", $session_id, $expiration);
 176         $response->push_header('Set-Cookie', $content);
 177         $response;
 178 }
 179
 180 ################################################################
 181 # \92Ê\8fí\83\8d\83O\83C\83\93\82ÌPOST\90æ
 182 # \83p\83X\83\8f\81[\83h\82ð\83`\83F\83b\83N\82µ\82Ä
 183 # \8aÔ\88á\82Á\82Ä\82¢\82½\82ç / \82Ö\83\8a\83\93\83N\82µ\82Ä\8fI\82í\82è
 184 # \8d\87\82Á\82Ä\82¢\82½\82ç\83Z\83b\83V\83\87\83\93\82ð\94\8ds\82µ /{SESSION}/index \82Ö
 185 sub action_login{
 186         my $request = shift;
 187         my $ci = new Keitairc::ClientInfo($request);
 188         my $content = $request->decoded_content();
 189         my ($password) = ($content =~ /^password=(.*)/);
 190
 191         ::log_debug("password [$password]");
 192         ::log_debug("web_password [" . $cf->web_password() . "]");
 193
 194         if($cf->web_password() eq $password){
 195                 my $s = $sm->add($ci->{header}->{user_agent}, $ci->serial_key());
 196                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 197                 return $view->redirect("/$s->{id}/index");
 198         }
 199
 200         # password mismatch
 201         my $view = new Keitairc::View($cf, $ci);
 202         return $view->redirect('/');
 203 }
 204
 205 ################################################################
 206 sub action_404{
 207         my $request = shift;
 208         my $ci = new Keitairc::ClientInfo($request);
 209         my $view = new Keitairc::View($cf, $ci);
 210         return $view->render('404.html', { action => $request->uri() });
 211 }
 212
 213 ################################################################
 214 sub action_robots_txt{
 215         my $request = shift;
 216         my $ci = new Keitairc::ClientInfo($request);
 217         my $view = new Keitairc::View($cf, $ci);
 218         return $view->render('robots.txt', { content_type => 'text/plain' });
 219 }
 220
 221 ################################################################
 222 # \82©\82ñ\82½\82ñ\83\8d\83O\83C\83\93\82ÌPOST\90æ
 223 # 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
 224 # \8d\87\82Á\82Ä\82¢\82½\82ç\83Z\83b\83V\83\87\83\93\95\9c\8bA\82µ\82Ä /{SESSION}/index \82Ö
 225 sub action_login_icc{
 226         my $request = shift;
 227         my $ci = new Keitairc::ClientInfo($request);
 228         if($ci->is_docomo()){
 229                 my $docomo_foma_icc = $ci->docomo_foma_icc();
 230                 if(length $docomo_foma_icc){
 231                         if(my $s = $sm->verify({serial_key => $docomo_foma_icc,
 232                                                 user_agent => $ci->user_agent()})){
 233                                 ::log_debug("redirect to /$s->{id}/index from docomo_foma_icc");
 234                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 235                                 return $view->redirect("/$s->{id}/index");
 236                         }
 237
 238                         if($docomo_foma_icc eq $cf->docomo_foma_icc()){
 239                                 my $s = $sm->add($ci->user_agent(), $docomo_foma_icc);
 240                                 ::log_debug("redirect to /$s->{id}/index from docomo_foma_icc");
 241                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 242                                 return $view->redirect("/$s->{id}/index");
 243                         }
 244
 245                         my $view = new Keitairc::View($cf, $ci);
 246                         return $view->render('login_icc.html', { icc => $docomo_foma_icc });
 247                 }
 248         }
 249
 250         my $view = new Keitairc::View($cf, $ci);
 251         return $view->render('root.html', { docomo => $ci->is_docomo() });
 252 }
 253
 254 ################################################################
 255 sub action_root{
 256         my $request = shift;
 257         my $ci = new Keitairc::ClientInfo($request);
 258
 259         if($ci->cookie_available()){
 260                 my $session_id = $ci->{cookie}->{sid};
 261                 if(length $session_id){
 262                         if($sm->verify({session_id => $session_id,
 263                                         user_agent => $ci->user_agent()})){
 264                                 ::log_debug("redirect to /$session_id/index from cookie");
 265                                 my $view = new Keitairc::View($cf, $ci, $session_id);
 266                                 return $view->redirect("/$session_id/index");
 267                         }
 268                 }
 269         }
 270
 271         if($ci->is_ezweb()){
 272                 my $subscriber_id = $ci->{header}->{x_up_subno};
 273                 if(length $subscriber_id){
 274                         if(my $s = $sm->verify({serial_key => $subscriber_id,
 275                                                 user_agent => $ci->user_agent()})){
 276                                 ::log_debug("redirect to /$s->{id}/index from subscriber_id");
 277                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 278                                 return $view->redirect("/$s->{id}/index");
 279                         }
 280
 281                         if($subscriber_id eq $cf->au_subscriber_id()){
 282                                 my $s = $sm->add($ci->user_agent(), $subscriber_id);
 283                                 ::log_debug("redirect to /$s->{id}/index from au_subscriber_id");
 284                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 285                                 return $view->redirect("/$s->{id}/index");
 286                         }
 287                 }
 288         }
 289
 290         if($ci->is_softbank()){
 291                 my $serial_key = $ci->softbank_serial();
 292                 if(length $serial_key){
 293                         if(my $s = $sm->verify({serial_key => $serial_key,
 294                                                 user_agent => $ci->user_agent()})){
 295                                 ::log_debug("redirect to /$s->{id}/index from softbank serial_key");
 296                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 297                                 return $view->redirect("/$s->{id}/index");
 298                         }
 299                         if($serial_key eq $cf->softbank_serial_key()){
 300                                 my $s = $sm->add($ci->user_agent(), $serial_key);
 301                                 ::log_debug("redirect to /$s->{id}/index from au_subscriber_id");
 302                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 303                                 return $view->redirect("/$s->{id}/index");
 304                         }
 305                 }
 306         }
 307
 308         my $view = new Keitairc::View($cf, $ci);
 309         return $view->render('root.html', { docomo => $ci->is_docomo() });
 310 }
 311
 312 ################################################################
 313 sub action_redirect_root{
 314         my $request = shift;
 315         my $ci = new Keitairc::ClientInfo($request);
 316         my $view = new Keitairc::View($cf, $ci);
 317         return $view->redirect('/');
 318 }
 319
 320 ################################################################
 321 sub send_message{
 322         my $request = shift;
 323         my $channel = shift;
 324
 325         my $message = $request->content();
 326         $message =~ s/^m=//;
 327         $message =~ s/\+/ /g;
 328         $message = uri_unescape($message);
 329
 330         if(length($message)){
 331                 my $jis = $message;
 332                 my $euc = $message;
 333                 Encode::from_to($jis, 'shiftjis', 'jis');
 334                 Encode::from_to($euc, 'shiftjis', 'euc-jp');
 335                 $irc->yield(privmsg => $channel => $jis);
 336                 my $cid = $ib->name2cid($channel);
 337                 $ib->add_message($cid, $euc, $cf->irc_nick());
 338                 $ib->message_added(1);
 339         }
 340 }
 341
 342 ################################################################
 343 # \93ü\97Í\82Í euc-jp
 344 sub render_line{
 345         local($_);
 346         my $in = shift;
 347         my $session_id = shift;
 348         my $buf;
 349
 350         for ((reverse(split("\n", $in)))[0 .. $cf->web_lines()]){
 351                 next unless defined;
 352                 next unless length;
 353
 354                 $_ = $ib->simple_escape($_);
 355                 $_ = $ib->colorize($_);
 356
 357                 for my $name ($pl->list_replace_plugins()){
 358                         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;
 359                 }
 360
 361                 s/\s+$//;
 362                 s/\s+/ /g;
 363                 $buf .= "$_<br />";
 364         }
 365
 366         Encode::from_to($buf, 'euc-jp', 'shiftjis');
 367         $buf;
 368 }
 369
 370 ################################################################
 371 sub log{
 372         my $m = shift;
 373         warn "keitairc: $m\n";
 374 }
 375
 376 sub log_die{
 377         my $m = shift;
 378         die "keitairc: $m\n";
 379 }
 380
 381 sub log_debug{
 382         my $m = shift;
 383         if($cf->debug()){
 384                 warn "keitairc(debug): $m\n";
 385         }
 386 }
 387
 388 __END__