keitairc

   1 #!/usr/bin/perl
   2 # keitairc
   3 # $Id: keitairc,v 1.39 2008-01-13 15:31: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.0b3', @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_topic => \&Keitairc::IrcCallback::irc_topic,
  78                 irc_332 => \&Keitairc::IrcCallback::irc_topicraw,
  79                 irc_352 => \&Keitairc::IrcCallback::irc_whoreply,
  80                 irc_ctcp_action => \&Keitairc::IrcCallback::irc_ctcp_action,
  81                 irc_disconnected => \&Keitairc::IrcCallback::irc_reconnect,
  82                 irc_error => \&Keitairc::IrcCallback::irc_reconnect,
  83                 irc_socketerr => \&Keitairc::IrcCallback::irc_reconnect,
  84         });
  85
  86 # create web server component
  87 POE::Component::Server::TCP->new(
  88         Alias => 'keitairc',
  89         Port => $cf->web_port(),
  90         ClientFilter => 'POE::Filter::HTTPD',
  91         ClientInput => \&http_request);
  92
  93 # fire up main loop
  94 $poe_kernel->run();
  95 exit 0;
  96
  97 ################################################################
  98 sub http_request{
  99         my ($kernel, $heap, $request) = @_[KERNEL, HEAP, ARG0];
 100
 101         # Filter::HTTPD sometimes generates HTTP::Response objects.
 102         # They indicate (and contain the response for) errors that occur
 103         # while parsing the client's HTTP request.  It's easiest to send
 104         # the responses as they are and finish up.
 105         if($request->isa('HTTP::Response')){
 106                 $heap->{client}->put($request);
 107         }elsif(my $response = dispatch($request)){
 108                 $heap->{client}->put($response);
 109         }
 110
 111         $kernel->yield('shutdown');
 112 }
 113
 114 ################################################################
 115 sub dispatch{
 116         my $request = shift;
 117         my $uri = $request->uri();
 118         my $ci = new Keitairc::ClientInfo($request);
 119
 120         ::log_debug("dispatch: $uri");
 121
 122         if($uri eq '/'){
 123                 return action_root($request);
 124         }
 125
 126         if($uri eq '/login'){
 127                 return action_login($request);
 128         }
 129
 130         if($uri eq '/login_icc'){
 131                 return action_login_icc($request);
 132         }
 133
 134         for my $name ($pl->list_action_plugins()){
 135                 if($uri =~ m|^/(S[a-zA-Z]{10})/$name/(.*)| ||
 136                    $uri =~ m|^/(S[a-zA-Z]{10})/$name$|){
 137                         if($sm->verify({session_id => $1, user_agent => $ci->user_agent()})){
 138                                 return add_cookie($pl->{plugins}->{$name}->{action_imprementation}($request, $name, $1, $2), $1);
 139                         }
 140                         return action_redirect_root($request);
 141                 }
 142         }
 143
 144         ::log("dispatch: don't know how to dispatch uri[$uri]");
 145         return action_404($request);
 146 }
 147
 148 ################################################################
 149 # adds session id cookie to http response object
 150 sub add_cookie{
 151         my $response = shift;
 152         my $session_id = shift;
 153
 154         my ($sec, $min, $hour, $mday, $mon, $year, $wday) = localtime(time + $cf->cookie_ttl());
 155         my $expiration =
 156                 sprintf('%.3s, %.2d-%.3s-%.4s %.2d:%.2d:%.2d',
 157                         qw(Sun Mon Tue Wed Thu Fri Sat)[$wday],
 158                         $mday,
 159                         qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)[$mon],
 160                         $year + 1900,
 161                         $hour,
 162                         $min,
 163                         $sec);
 164         my $content = sprintf("sid=%s; expires=%s; \n", $session_id, $expiration);
 165         $response->push_header('Set-Cookie', $content);
 166         $response;
 167 }
 168
 169 ################################################################
 170 # \92Ê\8fí\83\8d\83O\83C\83\93\82ÌPOST\90æ
 171 # \83p\83X\83\8f\81[\83h\82ð\83`\83F\83b\83N\82µ\82Ä
 172 # \8aÔ\88á\82Á\82Ä\82¢\82½\82ç / \82Ö\83\8a\83\93\83N\82µ\82Ä\8fI\82í\82è
 173 # \8d\87\82Á\82Ä\82¢\82½\82ç\83Z\83b\83V\83\87\83\93\82ð\94\8ds\82µ /{SESSION}/index \82Ö
 174 sub action_login{
 175         my $request = shift;
 176         my $ci = new Keitairc::ClientInfo($request);
 177         my $content = $request->decoded_content();
 178         my ($password) = ($content =~ /^password=(.*)/);
 179
 180         ::log_debug("password [$password]");
 181         ::log_debug("web_password [" . $cf->web_password() . "]");
 182
 183         if($cf->web_password() eq $password){
 184                 my $s = $sm->add($ci->{header}->{user_agent}, $ci->serial_key());
 185                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 186                 return $view->redirect("/$s->{id}/index");
 187         }
 188
 189         # password mismatch
 190         my $view = new Keitairc::View($cf, $ci);
 191         return $view->redirect("/");
 192 }
 193
 194 ################################################################
 195 sub action_404{
 196         my $request = shift;
 197         my $ci = new Keitairc::ClientInfo($request);
 198         my $view = new Keitairc::View($cf, $ci);
 199         return $view->render('404.html', { action => $request->uri() });
 200 }
 201
 202 ################################################################
 203 # \82©\82ñ\82½\82ñ\83\8d\83O\83C\83\93\82ÌPOST\90æ
 204 # 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
 205 # \8d\87\82Á\82Ä\82¢\82½\82ç\83Z\83b\83V\83\87\83\93\95\9c\8bA\82µ\82Ä /{SESSION}/index \82Ö
 206 sub action_login_icc{
 207         my $request = shift;
 208         my $ci = new Keitairc::ClientInfo($request);
 209         if($ci->is_docomo()){
 210                 my $docomo_foma_icc = $ci->docomo_foma_icc();
 211                 if(length $docomo_foma_icc){
 212                         if(my $s = $sm->verify({serial_key => $docomo_foma_icc,
 213                                                 user_agent => $ci->user_agent()})){
 214                                 ::log_debug("redirect to /$s->{id}/index from docomo_foma_icc");
 215                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 216                                 return $view->redirect("/$s->{id}/index");
 217                         }
 218
 219                         if($docomo_foma_icc eq $cf->docomo_foma_icc()){
 220                                 my $s = $sm->add($ci->user_agent(), $docomo_foma_icc);
 221                                 ::log_debug("redirect to /$s->{id}/index from docomo_foma_icc");
 222                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 223                                 return $view->redirect("/$s->{id}/index");
 224                         }
 225
 226                         my $view = new Keitairc::View($cf, $ci);
 227                         return $view->render('login_icc.html', { icc => $docomo_foma_icc });
 228                 }
 229         }
 230
 231         my $view = new Keitairc::View($cf, $ci);
 232         return $view->render('root.html', { docomo => $ci->is_docomo() });
 233 }
 234
 235 ################################################################
 236 sub action_root{
 237         my $request = shift;
 238         my $ci = new Keitairc::ClientInfo($request);
 239
 240         if($ci->cookie_available()){
 241                 my $session_id = $ci->{cookie}->{sid};
 242                 if(length $session_id){
 243                         if($sm->verify({session_id => $session_id,
 244                                         user_agent => $ci->user_agent()})){
 245                                 ::log_debug("redirect to /$session_id/index from cookie");
 246                                 my $view = new Keitairc::View($cf, $ci, $session_id);
 247                                 return $view->redirect("/$session_id/index");
 248                         }
 249                 }
 250         }
 251
 252         if($ci->is_ezweb()){
 253                 my $subscriber_id = $ci->{header}->{x_up_subno};
 254                 if(length $subscriber_id){
 255                         if(my $s = $sm->verify({serial_key => $subscriber_id,
 256                                                 user_agent => $ci->user_agent()})){
 257                                 ::log_debug("redirect to /$s->{id}/index from subscriber_id");
 258                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 259                                 return $view->redirect("/$s->{id}/index");
 260                         }
 261
 262                         if($subscriber_id eq $cf->au_subscriber_id()){
 263                                 my $s = $sm->add($ci->user_agent(), $subscriber_id);
 264                                 ::log_debug("redirect to /$s->{id}/index from au_subscriber_id");
 265                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 266                                 return $view->redirect("/$s->{id}/index");
 267                         }
 268                 }
 269         }
 270
 271         if($ci->is_softbank()){
 272                 my $serial_key = $ci->softbank_serial();
 273                 if(length $serial_key){
 274                         if(my $s = $sm->verify({serial_key => $serial_key,
 275                                                 user_agent => $ci->user_agent()})){
 276                                 ::log_debug("redirect to /$s->{id}/index from softbank serial_key");
 277                                 my $view = new Keitairc::View($cf, $ci, $s->{id});
 278                                 return $view->redirect("/$s->{id}/index");
 279                         }
 280                 }
 281         }
 282
 283         my $view = new Keitairc::View($cf, $ci);
 284         return $view->render('root.html', { docomo => $ci->is_docomo() });
 285 }
 286
 287 ################################################################
 288 sub action_redirect_root{
 289         my $request = shift;
 290         my $ci = new Keitairc::ClientInfo($request);
 291         my $view = new Keitairc::View($cf, $ci);
 292         return $view->redirect('/');
 293 }
 294
 295 ################################################################
 296 sub send_message{
 297         my $request = shift;
 298         my $channel = shift;
 299
 300         my $message = $request->content();
 301         $message =~ s/^m=//;
 302         $message =~ s/\+/ /g;
 303         $message = uri_unescape($message);
 304
 305         if(length($message)){
 306                 my $jis = $message;
 307                 my $euc = $message;
 308                 Encode::from_to($jis, 'shiftjis', 'jis');
 309                 Encode::from_to($euc, 'shiftjis', 'euc-jp');
 310                 $irc->yield(privmsg => $channel => $jis);
 311                 my $cid = $ib->name2cid($channel);
 312                 $ib->add_message($cid, $euc, $cf->irc_nick());
 313                 $ib->message_added(1);
 314         }
 315 }
 316
 317 ################################################################
 318 # \93ü\97Í\82Í euc-jp
 319 sub render_line{
 320         local($_);
 321         my $in = shift;
 322         my $session_id = shift;
 323         my $buf;
 324
 325         for ((reverse(split("\n", $in)))[0 .. $cf->web_lines()]){
 326                 next unless defined;
 327                 next unless length;
 328
 329                 $_ = $ib->simple_escape($_);
 330                 $_ = $ib->colorize($_);
 331
 332                 for my $name ($pl->list_replace_plugins()){
 333                         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;
 334                 }
 335
 336                 s/\s+$//;
 337                 s/\s+/ /g;
 338                 $buf .= "$_<br />";
 339         }
 340
 341         Encode::from_to($buf, 'euc-jp', 'shiftjis');
 342         $buf;
 343 }
 344
 345 ################################################################
 346 sub log{
 347         my $m = shift;
 348         warn "keitairc: $m\n";
 349         # TODO
 350 }
 351
 352 sub log_die{
 353         my $m = shift;
 354         die "keitairc: $m\n";
 355         # TODO
 356 }
 357
 358 sub log_debug{
 359         my $m = shift;
 360         warn "keitairc: $m\n";
 361         # TODO
 362 }
 363
 364 __END__