keitairc

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