root/lang/perl/tiarra/trunk/module/System/WebClient.pm @ 15324

Revision 15324, 62.4 kB (checked in by hio, 5 years ago)

sidにランダムいれわすれてた.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Date Revision Author HeadURL Id
Line 
1## ----------------------------------------------------------------------------
2#  System::WebClient.
3# -----------------------------------------------------------------------------
4# Mastering programmed by YAMASHINA Hio
5#
6# Copyright 2008 YAMASHINA Hio
7# -----------------------------------------------------------------------------
8# $Id$
9# -----------------------------------------------------------------------------
10package System::WebClient;
11use strict;
12use warnings;
13use Module;
14use base 'Module';
15use Tools::HTTPServer;
16use Tools::HTTPParser;
17use Log::Logger;
18use Auto::Utils;
19use BulletinBoard;
20use Module::Use qw(Tools::HTTPServer Tools::HTTPParser Log::Logger Auto::Utils);
21use Unicode::Japanese;
22
23use IO::Socket::INET;
24use Scalar::Util qw(weaken);
25
26our $VERSION = '0.05';
27
28our $DEBUG = 0;
29
30our $DEFAULT_MAX_LINES = 100;
31our $DEFAULT_SHOW_LINES = 20;
32our $DEFAULT_SITE_NAME  = "Tiarra::WebClient";
33our $DEFAULT_SESSION_EXPIRE = 7 * 24 * 60*60;
34
35=begin COMMENT
36
37System::WebClient - ブラウザ上でログを見たり発言したりできるようにする Tiarra モジュール.
38
39 /
40   #==> [POST/_post_list] ENTER.
41   #==> [GET/_gen_list]   /log/*/* を一覧.
42 /log/<network>/<channel>/
43   #==> [POST/_post_log] 発言.
44   #==> [GET/_gen_log]   ログの閲覧.
45   #==> ?r=XXX ==> ここまでは見たからこれの次から表示.
46   #==> ?x=XXX ==> 最新を表示するけれど,ここまではみたから表示しない.
47 /log/<network>/<channel>/info
48   #==> [POST/_post_chan_info] TOPIC/JOIN/PART/DELETE.
49   #==> [GET/_gen_chan_info]   チャンネル情報表示.
50 /config
51   #==> [POST/_post_config] NAME
52   #==> [GET/_gen_config]   shared時の名前設定
53 /style/style.css
54   #==> 空のCSSファイル.
55 <それ以外>
56   #==> 404.
57
58session 情報:
59  $req->{session}{seen} -- 未読管理.
60    $req->{session}{seen}{$netname}{$ch_short} = $recent内のオブジェクト.
61  $req->{session}{name} -- shared用の名前.
62
63(*) 存在するけれど閲覧許可のないページであっても,
64    403 (Forbidden) ではなく 404 (Not Found) を返す.
65(*) ENTER: チャンネル情報を作成. この情報はそこにチャンネルがある(あった)ということを
66           保持していて, PART後も残るため過去ログが閲覧できる.
67(*) DELETE: 保持しているチャンネル情報を削除.
68            そのチャンネルの情報がもういらないのなら, 存在していたことを削除できる.
69
70=end COMMENT
71
72=cut
73
741;
75
76# -----------------------------------------------------------------------------
77# $pkg->new().
78# (impl:tiarra-module)
79#
80#
81sub new
82{
83  my $pkg  = shift;
84  my $this = $pkg->SUPER::new(@_);
85
86  local($DEBUG) = $DEBUG || $this->config->debug;
87  $DEBUG and require Data::Dumper;
88
89  my $has_lwp = $Tools::HTTPServer::Client::HAS_HTTP_PARSER;
90  $this->_runloop->notify_msg(__PACKAGE__.", Tools::HTTPServer uses HTTP::Parser: ".($has_lwp?"yes":"no"));
91
92  $this->{last_sender} = undef;
93  $this->{last_msg}    = undef;
94  $this->{last_line}   = undef;
95  $this->{logger} = Log::Logger->new(
96    sub { $this->_log_writer(@_) },
97    $this,
98    qw(S_PRIVMSG  C_PRIVMSG S_NOTICE C_NOTICE),
99  );
100
101  # トップ何行かのキャッシュ.
102  $this->{bbs_val}   = undef;
103  $this->{cache}     = undef;
104  $this->{max_lines} = undef;
105  $this->{session_master} = undef;
106  $this->_load_cache();
107
108  my $config = $this->config;
109  my $host   = $config->bind_addr || '127.0.0.1';
110  my $port   = $config->bind_port || 8667;
111  my $path   = $config->path || '/';
112  $path =~ m{^/} or $path = "/$path";
113  $path =~ m{/$} or $path = "$path/";
114
115  $this->{host} = $host;
116  $this->{port} = $port;
117  $this->{path} = $path;
118
119  $this->{listener} = undef;
120
121  $this->_start_listener();
122 
123  $this;
124}
125
126# -----------------------------------------------------------------------------
127# $this->destruct().
128# (impl:tiarra-module)
129#
130sub destruct
131{
132  my $this = shift;
133
134  local($DEBUG) = $DEBUG || $this->config->debug;
135
136  if( my $lsnr = $this->{listener} )
137  {
138    if( $lsnr->installed )
139    {
140      $lsnr->uninstall();
141    }
142    $lsnr->close();
143    $this->{listener} = undef;
144  }
145
146  # 循環参照の切断.
147  $this->{logger} = undef;
148
149  $this->{bbs_val}{unloaded_at} = time;
150  $DEBUG and $this->_debug(__PACKAGE__."->destruct(), done.");
151}
152
153# -----------------------------------------------------------------------------
154# $obj->_load_cache().
155# 有効にされる前のぶんとかをキャッシュに反映.
156#
157sub _load_cache
158{
159  my $this = shift;
160
161  my $runloop = $this->_runloop;
162  my $BBS_KEY = __PACKAGE__.'/cache';
163  my $BBS_VAL = BulletinBoard->shared->get($BBS_KEY);
164  if( !$BBS_VAL )
165  {
166    $runloop->notify_msg(__PACKAGE__."#_load_cache, bbs[$BBS_KEY] initialize");
167    $BBS_VAL = {
168      inited_at   => time,
169      unloaded_at => 0,
170      cache       => {},
171      session     => {},
172    };
173    BulletinBoard->shared->set($BBS_KEY, $BBS_VAL);
174  }
175  $BBS_VAL->{session} ||= {};
176
177  $this->{bbs_val} = $BBS_VAL;
178  $this->{cache}   = $BBS_VAL->{cache};
179  $this->{session_master} = $BBS_VAL->{session};
180
181  $runloop->notify_msg(__PACKAGE__."#_load_cache, bbs[$BBS_KEY].inited_at ".localtime($BBS_VAL->{inited_at}));
182  $runloop->notify_msg(__PACKAGE__."#_load_cache, bbs[$BBS_KEY].unloaded_at ".($BBS_VAL->{unloaded_at}?localtime($BBS_VAL->{unloaded_at}):'-'));
183
184  my $networks = $runloop->networks('even-if-not-connected');
185
186  my %channels;
187  foreach my $network (values %$networks)
188  {
189    my $netname = $network->network_name;
190    my $channels = $network->channels('even-if-kicked-out');
191    foreach my $channel (values %$channels)
192    {
193      my $channame = $channel->name;
194      $this->{cache}{$netname}{$channame} ||= $this->_new_cache_entry($netname, $channame);
195      my $cache = $this->{cache}{$netname}{$channame};
196
197      # old version does not have these entries.
198      $this->{cache}{$netname}{$channame}{netname}  ||= $netname;
199      $this->{cache}{$netname}{$channame}{ch_short} ||= $channame;
200    }
201  }
202
203  my $limit = $this->config->max_lines || 0;
204  $limit =~ s/^0+//;
205  if( !$limit || $limit !~ /^[1-9]\d*\z/ )
206  {
207    $limit = $DEFAULT_MAX_LINES;
208  }
209  $this->{max_lines}{''} = $limit;
210}
211
212
213sub _new_cache_entry
214{
215  my $this = shift;
216  my $netname  = shift;
217  my $ch_short = shift;
218  +{
219    recent => [],
220    netname  => $netname,
221    ch_short => $ch_short,
222  };
223}
224
225# -----------------------------------------------------------------------------
226# $obj->message_io_hook($msg, $sender, $type).
227# (impl:tiarra-module)
228#
229sub message_arrived
230{
231  my ($this,$msg,$sender) = @_;
232
233  my $cmd = $msg->command;
234  if( $cmd ne 'PRIVMSG' && $cmd ne 'NOTICE' )
235  {
236    $this->_trace_msg($msg, $sender, '');
237  }
238
239  $msg;
240}
241
242sub message_io_hook
243{
244  my ($this,$msg,$sender,$type) = @_;
245  my @ret = ($msg);
246
247  if( $sender->isa('IrcIO::Server') )
248  {
249    # Serverとのio-hookのみ利用.
250    # なおかつPRIVMSG/NOTICE のみ.
251    my $cmd = $msg->command;
252    if( $cmd eq 'PRIVMSG' || $cmd eq 'NOTICE' )
253    {
254      # PRIVMSG/NOTICE はserverゆきのメッセージを利用.
255      my $msg = $msg->clone;
256
257      # サーバゆきのチャンネル名になっているので, ch_full に書き換え.
258      $msg->param(0, Multicast::attach($msg->param(0), $sender->network_name));
259
260      my $dummy;
261      if( $type eq 'out' )
262      {
263        # 送信だったらclientからおくられたように偽装.
264        $dummy = bless \my$x, 'IrcIO::Client';
265        $sender = $dummy;
266      }
267
268      eval{
269        $this->_trace_msg($msg, $sender, $type);
270      };
271      if( $@ )
272      {
273        $this->_runloop->notify_error(__PACKAGE__."#message_io_hook: _trace_msg: $@");
274      }
275
276      if( $dummy )
277      {
278        # デストラクタが呼ばれないように差し替えて破棄.
279        bless $dummy, 'UNIVERSAL';
280      }
281    }
282  }
283
284  @ret;
285}
286
287# -----------------------------------------------------------------------------
288# $this->_trace_msg($msg, $sender, '').    // from message_arrived.
289# $this->_trace_msg($msg, $sender, $type). // from message_io_hook.
290#
291sub _trace_msg
292{
293  my $this   = shift;
294  my $msg    = shift;
295  my $sender = shift;
296  my $type   = shift;
297
298  local($DEBUG) = $DEBUG || $this->config->debug;
299
300  ##RunLoop->shared_loop->notify_msg(__PACKAGE__."#_trace_msg, ".$msg->command." ($sender/$type)");
301
302  $this->{last_sender} = $sender;
303  $this->{last_msg}    = $msg;
304  $this->{last_line}   = undef;
305  eval{
306    $this->{logger}->log($msg,$sender);
307  };
308  $this->{last_sender} = undef;
309  $this->{last_msg}    = undef;
310  $this->{last_line}   = undef;
311  if( $@ )
312  {
313    RunLoop->shared_loop->notify_error(__PACKAGE__."#_trace_msg, ".$@);
314  }
315}
316
317# -----------------------------------------------------------------------------
318# $this->S_PRIVMSG(..)
319# $this->C_PRIVMSG(..)
320# $this->S_NOTICE(..)
321# $this->C_NOTICE(..)
322# (impl/log-formatter).
323# デフォルトのだとprivが寂しいのでトラップ.
324#
325{
326no warnings 'once';
327*S_PRIVMSG = \&PRIVMSG_or_NOTICE;
328*S_NOTICE  = \&PRIVMSG_or_NOTICE;
329*C_PRIVMSG = \&PRIVMSG_or_NOTICE;
330*C_NOTICE  = \&PRIVMSG_or_NOTICE;
331}
332
333sub PRIVMSG_or_NOTICE
334{
335  my ($this,$msg,$sender) = @_;
336  my $line = $this->{logger}->_build_message($msg, $sender);
337  $this->{last_line} = $line;
338  [$line->{ch_long}, $line->{line}];
339}
340
341# -----------------------------------------------------------------------------
342# $this->_log_writer().
343# (impl/log-writer).
344#
345sub _log_writer
346{
347  my ($this, $channel, $line) = @_;
348  my $info   = $this->{last_line};
349
350  #RunLoop->shared_loop->notify_msg(">> $channel $line");
351  if( !$info )
352  {
353    # PRIVMSG/NOTICE 以外.
354    my $sender = $this->{last_sender};
355
356    my ($ch_short, $netname, $explicit) = Multicast::detach($channel);
357    $explicit or $netname = $this->{last_sender}->network_name;
358    $info = {
359      netname  => $netname,
360      ch_short => $ch_short,
361      msg       => $line,
362      formatted => $line,
363    };
364  }else
365  {
366    # チャンネル名なしに整形し直し.
367    $line = sprintf(
368      '%s%s%s %s',
369      $info->{marker}[0],
370      $info->{speaker},
371      $info->{marker}[1],
372      $info->{msg},
373    );
374  };
375  my $netname  = $info->{netname};
376  my $ch_short = $info->{ch_short};
377
378  my @tm = localtime(time());
379  $tm[5] += 1900;
380  $tm[4] += 1;
381  my $time = sprintf('%02d:%02d:%02d', @tm[2,1,0]);
382  $info->{tm}   = \@tm;
383  $info->{time} = $time;
384  $info->{ymd} = sprintf('%04d-%02d-%02d', @tm[5,4,3]);
385  $info->{formatted} = "$time $line";
386
387  #RunLoop->shared_loop->notify_msg(__PACKAGE__."#_log_writer, $netname, $ch_short, [$channel] $line");
388
389  my $cache = $this->{cache}{$netname}{$ch_short};
390  if( !$cache )
391  {
392    $cache = $this->{cache}{$netname}{$ch_short} = $this->_new_cache_entry($netname, $ch_short);
393  }
394
395  my $recent = $cache->{recent};
396  my $prev   = @$recent && $recent->[-1];
397  $info->{lineno} = $prev && $prev->{ymd} eq $info->{ymd} ? $prev->{lineno} + 1 : 1;
398
399  push(@$recent, $info);
400  my $limit = $this->{max_lines}{''};
401  @$recent > $limit and @$recent = @$recent[-$limit..-1];
402}
403
404# -----------------------------------------------------------------------------
405# $this->_start_listener().
406# new()の時に呼ばれる.
407# Tools::HTTPServer を起動.
408#
409sub _start_listener
410{
411  my $this = shift;
412
413  my $host = $this->{host};
414  my $port = $this->{port};
415  my $path = $this->{path};
416
417  my $lsnr = Tools::HTTPServer->new();
418  $lsnr->start(
419    Host => $host,
420    Port => $port,
421    Path => $path,
422    CallbackObject => $this,
423  );
424  RunLoop->shared_loop->notify_msg(__PACKAGE__.", listen on ".$lsnr->where);
425
426  $this->{listener} = $lsnr;
427
428  $this;
429}
430
431# -----------------------------------------------------------------------------
432# $this->_debug($msg).
433# デバッグメッセージ送信用.
434#
435sub _debug
436{
437  my $this = shift;
438  my $msg = shift;
439  RunLoop->shared_loop->notify_msg($msg);
440}
441
442# -----------------------------------------------------------------------------
443# $this->_on_request($cli, $req).
444# (impl:HTTPServer-callback)
445#
446sub _on_request
447{
448  my $this = shift;
449  my $cli  = shift;
450  my $req  = shift;
451
452  local($DEBUG) = $DEBUG || $this->config->debug;
453
454  my $peer = $cli->sock->peerhost .':'. $cli->sock->peerport;
455  foreach my $eff ( $this->config->extract_forwarded_for('all') )
456  {
457    local($Tools::HTTPParser::DEBUG) = $Tools::HTTPParser::DEBUG || $DEBUG;
458    my $allows = [ split( /\s+|\s*,\s*/, $eff ) ];
459    if( @$allows && Tools::HTTPParser->extract_forwarded_for($req, $allows) )
460    {
461      $peer = "$req->{RemoteAddr}($peer)";
462      last;
463    }
464  }
465  $DEBUG and print __PACKAGE__."#_on_request, peer=$peer, ".Data::Dumper->new([$req])->Dump;
466
467  my $conflist = $this->_find_conf($req);
468  $req = {
469    %$req,
470    client    => $cli,
471    peer      => $peer,
472    conflist  => $conflist,
473    authtoken => undef,
474    ua_type   => undef,
475    cgi_hash  => undef, # generated on demand.
476    req_param => undef, # config params, generated on demand.
477    session   => undef,
478  };
479  if( my $ua = $req->{Header}{'User-Agent'} )
480  {
481    if( $ua =~ /(UP\.Browser|DoCoMo|J-PHONE|Vodafone|SoftBank)/i )
482    {
483      $req->{ua_type} = 'mobile';
484    }else
485    {
486      $req->{ua_type} = 'pc';
487    }
488  }else
489  {
490    $req->{ua_type} = 'pc';
491  }
492
493  if( $req->{Method} !~ /^(GET|POST|HEAD)\z/ )
494  {
495    $DEBUG and $this->_debug("$peer: method not allowed: $req->{Method}");
496    # 405 Method Not Allowed
497    $this->_response($req, 405);
498    return;
499  }
500
501  if( !@$conflist )
502  {
503    $DEBUG and $this->_debug("$peer: Forbidden by no conf");
504    # 403 Forbidden.
505    $this->_response($req, 403);
506    return;
507  }
508
509  $DEBUG and $this->_debug("$peer: check auth ...");
510  my $accepted_list = $this->auth($conflist, $req);
511  my $authtoken_list;
512  if( @$accepted_list )
513  {
514    $DEBUG and $this->_debug("$peer: has auth");
515    # update @$conflist.
516    @$conflist = map{ $_->{conf} } @$accepted_list;
517
518    # extract authtoken list.
519    $authtoken_list = [];
520    foreach my $auth (@$accepted_list)
521    {
522      if( grep { $_ eq $auth->{token} } @$authtoken_list )
523      {
524        # no dup.
525        next;
526      }
527      push(@$authtoken_list, $auth->{token});
528    }
529  }else
530  {
531    $DEBUG and $this->_debug("$peer: no auth");
532    @$conflist = grep{ !$_->{auth} } @$conflist;
533    $DEBUG and $this->_debug("$peer: has guest entry ".(@$conflist?"yes":"no"));
534  }
535
536  my $need_auth = @$conflist == 0;
537  if( $req->{Path} =~ /\?auth(?:=|[&;]|$)/ )
538  {
539    $need_auth = 1;
540  }
541  if( $need_auth )
542  {
543    $DEBUG and $this->_debug("$peer: response: Authenticate Required");
544    my $realm = 'Authenticate Required';
545    # 401 Unauthorized
546    my $res = {
547      Code => 401,
548      Header => {
549        'WWW-Authenticate' => qq{Basic realm="$realm"},
550      },
551    };
552    $this->_response($req, $res);
553    return;
554  }
555
556
557  $req->{authtoken} = ($authtoken_list && @$authtoken_list) ? $authtoken_list->[0]->{atoken} : undef;
558  if( !$req->{authtoken} )
559  {
560    $DEBUG and $this->_debug("$peer: no authtoken, check cookie");
561    CHECK_COOKIE:{
562      my $cookies = $req->{Header}{Cookie} || '';
563      my @cookies = split(/\s*[;,]\s*/, $cookies);
564      my $ck = shift @cookies || '';
565      my ($key, $val) = split(/=/, $ck);
566      $key && $val or last CHECK_COOKIE;
567      $val =~ s/%([0-9a-f]{2})/pack("H*",$1)/ge;
568    $DEBUG and $this->_debug("$peer: cookie: [$key]=[$val]");
569      if( $val !~ /^sid:(\d+):(\d+):(\d+)(?::|\z)/ )
570      {
571        last CHECK_COOKIE;
572      }
573      my ($seed, $seq, $check) = ($1, $2, $3);
574      my $sid = "sid:$seed:$seq:$check";
575      $req->{authtoken} = $sid;
576      $DEBUG and $this->_debug("$peer: $sid");
577    }
578  }
579
580  my $mode = $this->_get_req_param($req, 'mode');
581  if( $mode eq 'owner' )
582  {
583    $req->{authtoken} ||= "owner:*";
584  }
585  $this->_update_session($req);
586  if( $mode ne 'owner' && !$req->{session}{name} )
587  {
588    $this->_debug("$peer: login required (no name).");
589    return $this->_login($req);
590  }
591
592
593  $this->_debug("$peer: accept: sid=$req->{sid}");
594  $this->_dispatch($req);
595}
596
597# -----------------------------------------------------------------------------
598# my $sess = $this->_new_session().
599# Set-Cookie も設定される.
600#
601sub _new_session
602{
603  my $this = shift;
604  my $req  = shift;
605
606  our $seed ||= int(rand(0xFFFF_FFFF));
607  our $seq  ||= 0;
608  $seq ++;
609  my $rnd = int(rand(0xFFFF_FFFF));
610  my $sid = "sid:$seed:$seq:$rnd";
611  $DEBUG and $this->_debug("_new_session: $sid");
612
613  $req->{authtoken} = $sid;
614  my $sess = $this->_update_session($req);
615  $req->{cookies}{SID} = $sess->{_sid};
616  $sess;
617}
618
619# -----------------------------------------------------------------------------
620# my $sess = $this->_delete_session($req).
621# 削除用の Set-Cookie も設定される.
622#
623sub _delete_session
624{
625  my $this = shift;
626  my $req  = shift;
627  my $sess = $req->{session} || {};
628  my $sid  = $sess->{_sid} || '';
629  my $deleted = delete $this->{session_master}{$sid};
630  if( $deleted )
631  {
632    $deleted->{_deleted} = 1;
633  }
634  if( $sid )
635  {
636    $req->{cookies}{SID} = undef;
637  }
638  $deleted;
639}
640
641# -----------------------------------------------------------------------------
642# $this->_update_session($req);
643# 指定のsessionを取得.
644# なかったら生成される.
645#
646sub _update_session
647{
648  my $this = shift;
649  my $req  = shift;
650
651  my $sid = $req->{authtoken};
652  if( !$sid )
653  {
654    $DEBUG and $this->_debug("_get_session: no sid");
655    $req->{session} = {};
656    return;
657  }
658
659  my $sess = ($this->{session_master}{$sid} ||= {});
660  my $now  = time;
661  if( $sess->{_updated_at} )
662  {
663    if( $sess->{_updated_at} + $DEFAULT_SESSION_EXPIRE < $now )
664    {
665      # clean up.
666      $sess = {};
667      $this->{session_master}{$sid} = $sess;
668    }
669  }
670
671  $sess->{_sid}        ||= $sid;
672  $sess->{_created_at} ||= $now;
673  $sess->{_expire}     ||= $DEFAULT_SESSION_EXPIRE;
674  $sess->{_updated_at} =   $now;
675
676  # $sess->{seen} = \%seen;
677  # $sess->{name} = $name;
678  $DEBUG and $this->_debug("_get_session: ".Dumper($sess));use Data::Dumper;
679
680  $req->{session} = $sess;
681
682  $sess;
683}
684
685sub auth
686{
687  my $this     = shift;
688  my $conflist = shift;
689  my $req      = shift;
690  my @accepts;
691
692  # 認証関数.
693  # $val = $sub->($this, \@param, $req).
694  # \%hashref #==> accept.
695  # undef     #==> ignore.
696  # ''        #==> deny.
697  our $AUTH ||= {
698    ':basic'    => \&_auth_basic,
699    ':softbank' => \&_auth_softbank,
700    ':au'       => \&_auth_au,
701  };
702
703  foreach my $conf (@$conflist)
704  {
705    $DEBUG and $this->_debug("$req->{peer}: check auth for $conf->{name}");
706    my $authlist = $conf->{auth} or next;
707    foreach my $auth (@$authlist)
708    {
709      my @param = split(' ', $auth || '');
710      if( !@param )
711      {
712        $DEBUG and ::printmsg("$req->{peer}: - skip: empty value");
713        next;
714      }
715      $param[0] =~ /^:/ or unshift(@param, ':basic');
716      my $auth_sub = $AUTH->{$param[0]};
717      if( !$auth_sub )
718      {
719        $DEBUG and ::printmsg("$req->{peer}: - skip: unsupported: $param[0]");
720        next;
721      }
722      my $val = $this->$auth_sub(\@param, $req);
723      if( $val )
724      {
725        $DEBUG and $this->_debug("$req->{peer}: - $conf->{name} accepted ($param[0])");
726        push(@accepts, {
727          atoken => $val->{atoken}, # auth token, string or undef.
728          conf   => $conf,
729        });
730      }elsif( defined($val) )
731      {
732        $DEBUG and $this->_debug("$req->{peer}: auth denied by $conf->{name}");
733        return undef;
734      }
735    }
736  }
737  \@accepts;
738}
739
740sub _auth_basic
741{
742  my $this  = shift;
743  my $param = shift;
744  my $req   = shift;
745
746  my $line = $req->{Header}{Authorization};
747  if( !$line )
748  {
749    $DEBUG and ::printmsg("$req->{peer}: no Authorization: header");
750    return;
751  }
752
753  my ($type, $val) = split(' ', $line, 2);
754  if( $type ne 'Basic' )
755  {
756    $DEBUG and ::printmsg("$req->{peer}: not Basic Authorization (got $type)");
757    return;
758  }
759
760  require MIME::Base64;
761  my $dec = MIME::Base64::decode($val);
762  my ($user,$pass) = split(/:/, $dec, 2);
763
764  if( !_verify_value($param->[1], $user) )
765  {
766    defined($user) or $user = '';
767    $DEBUG and ::printmsg("$req->{peer}: $param->[0] user $param->[1] does not match with '$user' (user)");
768    return;
769  }
770  if( !_verify_value($param->[2], $pass) )
771  {
772    defined($pass) or $pass = '';
773    $DEBUG and ::printmsg("$req->{peer}: $param->[0] pass $param->[2] does not match with '$pass' (pass)");
774    return;
775  }
776
777  # accept.
778  $DEBUG and ::printmsg("$req->{peer}: accept user $param->[0] pass $param->[2] with '$user' '$pass'");
779  +{
780    id => "basic:$user",
781    atoken => undef,
782  };
783}
784
785sub _auth_softbank
786{
787  my $this  = shift;
788  my $param = shift;
789  my $req   = shift;
790
791  #TODO: carrier ip-addresses range.
792
793  # UIDはhttp領域若しくはsecure.softbank.ne.jp経由.
794  # SNは端末の設定.
795  my $uid = $req->{Header}{'X-JPHONE-UID'};
796  my $sn = do{
797    my ($ua1) = split(' ', $req->{Header}{'User-Agent'} || '');
798    my @ua = split('/', $ua1 || '');
799    my $carrier = uc($ua[0] || '');
800    my $sn = $carrier eq 'J-PHONE'  ? $ua[3]
801           : $carrier eq 'VODAFONE' ? $ua[4]
802           : $carrier eq 'SOFTBANK' ? $ua[4]
803           : undef;
804    $sn;
805  };
806  if( _verify_value($param->[1], $uid) )
807  {
808    # accept.
809    my $id = "softbank:$uid";
810    return +{
811      id     => $id,
812      atoken => $id,
813    };
814  }
815  if( _verify_value($param->[1], $sn) )
816  {
817    # accept.
818    my $id = "softbank:$sn";
819    return +{
820      id     => $id,
821      atoken => $id,
822    };
823  }
824  defined($uid) or $uid = '';
825  defined($sn)  or $sn  = '';
826  $DEBUG and ::printmsg("$req->{peer}: $param->[0] pass $param->[1] does not match with '$uid' (uid), '$sn' (sn)");
827  return;
828}
829
830sub _auth_au
831{
832  my $this  = shift;
833  my $param = shift;
834  my $req   = shift;
835
836  #TODO: carrier ip-addresses range.
837  # http://www.au.kddi.com/ezfactory/tec/spec/ezsava_ip.html
838  my $subno = $req->{Header}{'X-UP-SUBNO'};
839  if( !_verify_value($param->[1], $subno) )
840  {
841    defined($subno) or $subno = '';
842    $DEBUG and ::printmsg("$req->{peer}: $param->[0] pass $param->[1] does not match with '$subno' (subno)");
843    return;
844  }
845  my $id = return "au:$subno";
846  return +{
847    id     => $id,
848    atoken => $id,
849  };
850}
851
852# -----------------------------------------------------------------------------
853# $this->_login($req).
854# special case for _dispatch().
855#
856sub _login
857{
858  my $this = shift;
859  my $req  = shift;
860
861  $DEBUG and $this->_debug("$req->{peer}: login: process login dispatcher");
862  my $path = $req->{Path};
863  if( $path !~ s{\Q$this->{path}}{/} )
864  {
865    $this->_response($req, 404);
866    return;
867  }
868  $path =~ s/\?.*//;
869
870  if( $path eq '/' )
871  {
872    $this->_location($req, "/login");
873  }elsif( $path eq '/login' )
874  {
875    my $done = $req->{Method} eq 'POST' && $this->_post_login($req);
876    if( !$done )
877    {
878      my $html = $this->_gen_login($req);
879      $this->_new_session($req);
880      $this->_response($req, [html=>$html]);
881    }
882  }elsif( $path eq '/logout' )
883  {
884    # but not loged in.
885    $this->_location($req, "/login");
886  }else
887  {
888    $this->_response($req, 404);
889    return;
890  }
891}
892
893sub _post_login
894{
895  my $this = shift;
896  my $req  = shift;
897
898  my $cgi = $this->_get_cgi_hash($req);
899  if( my $name = $cgi->{n} )
900  {
901    $DEBUG and $this->_debug("$req->{peer}: _post_login: name=$name");
902    $this->_new_session($req); # regen.
903    $req->{session}{name} = $name;
904    my $path = $cgi->{path} || "/";;
905    $this->_location($req, $path);
906    return 1;
907  }
908
909  $DEBUG and $this->_debug("$req->{peer}: _post_login: skip");
910  undef;
911}
912sub _gen_login
913{
914  my $this = shift;
915  my $req  = shift;
916
917  my $tmpl = $this->_gen_login_html();
918  $this->_expand($req, $tmpl, {
919    NAME        => $this->_escapeHTML($req->{session}{name} || '' ),
920    PATH        => '',
921  });
922}
923sub _gen_login_html
924{
925  <<HTML;
926<?xml version="1.0" encoding="utf-8" ?>
927<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
928<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="ja-JP">
929<head>
930  <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
931  <meta http-equiv="Content-Style-Type"  content="text/css" />
932  <meta http-equiv="Content-Script-Type" content="text/javascript" />
933  <link rel="stylesheet" type="text/css" href="<&CSS>" />
934  <title>login</title>
935</head>
936<body>
937<div class="main">
938<div class="uatype-<&UA_TYPE>">
939
940<h1>Login</h1>
941
942<form action="login" method="post">
943名前: <input type="text" name="n" value="<&NAME>" /><br />
944<input type="submit" value="Login" /><br />
945<input type="hidden" name="path" value="<&PATH>" />
946</form>
947
948</div>
949</div>
950</body>
951</html>
952HTML
953}
954
955# -----------------------------------------------------------------------------
956# $this->_dispatch($req).
957#
958sub _dispatch
959{
960  my $this = shift;
961  my $req  = shift;
962
963  my $path = $req->{Path};
964  if( $path !~ s{\Q$this->{path}}{/} )
965  {
966    $this->_response($req, 404);
967    return;
968  }
969  $path =~ s/\?.*//;
970
971  if( $path eq '/' )
972  {
973    my $done = $req->{Method} eq 'POST' && $this->_post_list($req);
974    if( !$done )
975    {
976      my $html = $this->_gen_list($req);
977      $this->_response($req, [html=>$html]);
978    }
979  }elsif( $path =~ m{^/log/} )
980  {
981    my ($_blank, $_cmd, $netname, $ch_short, $param) = split('/', $path, 5);
982    if( !defined($param) )
983    {
984      if( !$netname || !$ch_short )
985      {
986        $this->_location($req, "/");
987      }else
988      {
989        $this->_location($req, "/log/$netname/$ch_short/");
990      }
991      return;
992    }
993
994    $ch_short =~ s/%([0-9a-f]{2})/pack("H*",$1)/gie;
995    my $ch_short_orig = $ch_short;
996    my $netname_orig  = $netname;
997    ($ch_short, $netname) = $this->_detect_channel($ch_short, $netname);
998    if( !$ch_short )
999    {
1000      RunLoop->shared_loop->notify_msg(__PACKAGE__."#_dispatch($path), not in cache ($netname_orig/$ch_short_orig)");
1001      $this->_response($req, 404);
1002      return;
1003    }
1004
1005    if( !$this->_can_show($req, $ch_short, $netname) )
1006    {
1007      #RunLoop->shared_loop->notify_msg(__PACKAGE__."#_dispatch($path), could not show ($netname/$ch_short)");
1008      $this->_response($req, 404);
1009      return;
1010    }
1011    #RunLoop->shared_loop->notify_msg(__PACKAGE__."#_dispatch($path), ok ($netname/$ch_short/$param)");
1012    if( $param eq '' )
1013    {
1014      my $done = $req->{Method} eq 'POST' && $this->_post_log($req, $netname, $ch_short);
1015      if( !$done )
1016      {
1017        my $html = $this->_gen_log($req, $netname, $ch_short);
1018        $this->_response($req, [html=>$html]);
1019      }
1020    }elsif( $param eq 'info' )
1021    {
1022      my $done = $req->{Method} eq 'POST' && $this->_post_chan_info($req, $netname, $ch_short);
1023      if( !$done )
1024      {
1025        my $html = $this->_gen_chan_info($req, $netname, $ch_short);
1026        $this->_response($req, [html=>$html]);
1027      }
1028    }else
1029    {
1030      $this->_response($req, 404);
1031    }
1032  }elsif( $path eq '/style/style.css' )
1033  {
1034    $this->_response($req, [css=>'']);
1035  }elsif( $path eq '/login' )
1036  {
1037    $this->_login($req);
1038  }elsif( $path eq '/logout' )
1039  {
1040    $this->_delete_session($req);
1041    $this->_location($req, "/");
1042  }elsif( $path eq '/config' )
1043  {
1044    my $done = $req->{Method} eq 'POST' && $this->_post_config($req);
1045    if( !$done )
1046    {
1047      my $html = $this->_gen_config($req);
1048      $this->_response($req, [html=>$html]);
1049    }
1050  }else
1051  {
1052    $this->_response($req, 404);
1053  }
1054}
1055
1056# ($ch_short, $netname) = $this->_detect_channel($ch_short, $netname).
1057sub _detect_channel
1058{
1059  my $this = shift;
1060  my $ch_short = shift;
1061  my $netname  = shift;
1062
1063  if( $ch_short =~ s/^=// )
1064  {
1065    # priv or special channels.
1066    if( $this->{cache}{$netname}{$ch_short} )
1067    {
1068      return wantarray ? ($ch_short, $netname) : $ch_short;
1069    }
1070    foreach my $extract_line ( $this->config->extract_network('all') )
1071    {
1072      my ($extract, $sep) = split(' ', $extract_line);
1073      $sep ||= '@';
1074      my $ch_long = $this->_attach($ch_short, $netname, $sep);
1075      if( $this->{cache}{$extract}{$ch_long} )
1076      {
1077        return wantarray ? ($ch_long, $extract) : $ch_short;
1078      }
1079    }
1080    # not found.
1081    return undef;
1082  }
1083
1084  if( $ch_short =~ s/^!// )
1085  {
1086    foreach my $key (keys %{$this->{cache}{$netname}})
1087    {
1088      $key =~ /^![0-9A-Z]{5}/ or next;
1089      substr($key, 6) eq $ch_short or next;
1090      return wantarray ? ($key, $netname) : $key;
1091    }
1092    # try decode from sjis.
1093    my $ch2 = Unicode::Japanese->new($ch_short,'sjis')->utf8;
1094    foreach my $key (keys %{$this->{cache}{$netname}})
1095    {
1096      $key =~ /^![0-9A-Z]{5}/ or next;
1097      substr($key, 6) eq $ch2 or next;
1098      return wantarray ? ($key, $netname) : $key;
1099    }
1100
1101    foreach my $extract_line ( $this->config->extract_network('all') )
1102    {
1103      my ($extract, $sep) = split(' ', $extract_line);
1104      $sep ||= '@';
1105      my $ch_long  = $this->_attach($ch_short, $netname, $sep);
1106      my $ch_long2 = $this->_attach($ch2,      $netname, $sep);
1107      foreach my $key (keys %{$this->{cache}{$extract}})
1108      {
1109        $key =~ /^![0-9A-Z]{5}/ or next;
1110        my $subkey = substr($key, 6);
1111        if( $subkey eq $ch_long || $subkey eq $ch_long2 )
1112        {
1113          return wantarray ? ($key, $extract) : $key;
1114        }
1115      }
1116    }
1117
1118    # not found.
1119    return undef;
1120  }
1121
1122  # normal channels.
1123  $ch_short = '#'.$ch_short;
1124  if( $this->{cache}{$netname}{$ch_short} )
1125  {
1126    # found.
1127    return wantarray ? ($ch_short, $netname) : $ch_short;
1128  }
1129
1130  foreach my $extract_line ( $this->config->extract_network('all') )
1131  {
1132    my ($extract, $sep) = split(' ', $extract_line);
1133    $sep ||= '@';
1134    my $ch_long = $this->_attach($ch_short, $netname, $sep);
1135    if( $this->{cache}{$extract}{$ch_long} )
1136    {
1137      return wantarray ? ($ch_long, $extract) : $ch_short;
1138    }
1139  }
1140
1141  # try decode from sjis.
1142  my $ch2 = Unicode::Japanese->new($ch_short,'sjis')->utf8;
1143  if( $this->{cache}{$netname}{$ch2} )
1144  {
1145    return wantarray ? ($ch2, $netname) : $ch2;
1146  }
1147
1148  # not found.
1149  return undef;
1150}
1151
1152sub _response
1153{
1154  my $this = shift;
1155  my $req  = shift;
1156  my $res  = shift; # number or hash-ref or array-ref.
1157
1158  if( ref($res) eq 'ARRAY' )
1159  {
1160    my $spec = $res;
1161    if( $spec->[0] eq 'html' )
1162    {
1163      my $html = $spec->[1];
1164      $res = {
1165        Code => 200,
1166        Header => {
1167          'Content-Type'   => 'text/html; charset=utf-8',
1168          'Content-Length' => length($html),
1169        },
1170        Content => $html,
1171      };
1172    }elsif( $spec->[0] eq 'css' )
1173    {
1174      my $css = $spec->[1];
1175      $res = {
1176        Code => 200,
1177        Header => {
1178          'Content-Type'   => 'text/css; charset=utf-8',
1179          'Content-Length' => length($css),
1180        },
1181        Content => $css,
1182      };
1183    }else
1184    {
1185      die "unkown response spec: $spec->[0]";
1186    }
1187  }
1188  if( $req->{cookies} )
1189  {
1190    my @cookies;
1191    foreach my $key (sort keys %{$req->{cookies}})
1192    {
1193      my $val = $req->{cookies}{$key};
1194      $key =~ /^[a-zA-Z]\w+\z/ or die "invalid cookie name: $key";
1195      if( defined($val) )
1196      {
1197        $val =~ s/([^-.\w])/'%'.unpack("H*",$1)/ge;
1198        length($val) >= 100 and die "value of cookies.$key is too long";
1199      }else
1200      {
1201        # delete.
1202        $val = "x; expires=Sun, 10-Jun-2001 12:00:00 GMT";
1203      }
1204      my $cookie = "$key=$val; path=$this->{path}";
1205      push(@cookies, $cookie);
1206    }
1207    if( @cookies )
1208    {
1209      ref($res) or $res = {
1210        Code => $res,
1211      };
1212      $res->{Header}{'Set-Cookie'} = $cookies[0];
1213      @cookies >= 2 and die "currently multiple cookies are not supported";
1214    }
1215  }
1216
1217  my $cli = $req->{client};
1218  $cli->response($res);
1219  #$DEBUG and $this->_debug( Tools::HTTPParser->to_string($res) );
1220
1221  # no Keep-Alive.
1222  $req->{client}->disconnect_after_writing();
1223
1224  return;
1225}
1226
1227sub _location
1228{
1229  my $this = shift;
1230  my $req  = shift;
1231  my $path = shift;
1232
1233  $DEBUG and $this->_debug("$req->{peer}: location: $path");
1234  $path = $this->{path} . $path;
1235  $path =~ s{//+}{/}g;
1236  my $res = {
1237    Code => 302,
1238    Header => {
1239      'Location' => $path,
1240    },
1241  };
1242  $this->_response($req, $res);
1243}
1244
1245# -----------------------------------------------------------------------------
1246# $conflist = $this->_find_conf($req).
1247# $conflist: この接続元に対して利用可能な allow 情報の一覧.
1248# この時点ではまだ接続元IPアドレスでのチェックのみ.
1249#
1250sub _find_conf
1251{
1252  my $this = shift;
1253  my $req  = shift;
1254  my $peerhost = $req->{RemoteAddr};
1255
1256  my @conflist;
1257
1258  my $config = $this->config;
1259  foreach my $key (map{split(' ',$_)}$config->allow('all'))
1260  {
1261    my $name  = "allow-$key";
1262    my $block = $config->$name('block') or next;
1263    my $hosts = [$block->host('all')];
1264    my $match = Mask::match_deep($hosts, $peerhost);
1265    defined($match) or next;
1266    $match or last;
1267    my $allow = {
1268      name  => $name,
1269      block => $block,
1270      masks => [$block->mask('all')], # 公開するチャンネルの一覧.
1271      auth  => [$block->auth('all')],
1272    };
1273    push(@conflist, $allow);
1274  }
1275
1276  \@conflist;
1277}
1278
1279# -----------------------------------------------------------------------------
1280# $match = _verify_value($enc, $plain).
1281# パスワードの比較検証.
1282# "{MD5}xxx" (MD5)
1283# "{SMD5}xxx" (Salted MD5, hex(md5(pass+salt)+salt)
1284# "{B}xxx"   (BASE64)
1285# "{RAW}xxx" (生パスワード)
1286# "{CRYPT}xxx" (cryptパスワード)
1287# "xxx"      (生パスワード)
1288#
1289sub _verify_value
1290{
1291  my $enc   = shift;
1292  my $plain = shift;
1293  if( !defined($enc) || !defined($plain) )
1294  {
1295    return undef;
1296  }
1297  my $type = $enc =~ s/^\{(.*?)\}// ? $1 : 'RAW';
1298
1299  if( $type =~ /^(B|B64|BASE64)\z/ )
1300  {
1301    eval { require MIME::Base64; };
1302    if( $@ )
1303    {
1304      die "no MIME::Base64";
1305    }
1306    my $cmp = MIME::Base64::encode($plain, '');
1307    return $enc eq $cmp;
1308  }elsif( $type =~ /^(MD5)\z/ )
1309  {
1310    eval { require Digest::MD5; };
1311    if( $@ )
1312    {
1313      die "no Digest::MD5";
1314    }
1315    my $cmp = Digest::MD5::md5_hex($plain);
1316    return $cmp eq lc($enc);
1317  }elsif( $type =~ /^(SMD5)\z/ )
1318  {
1319    eval { require Digest::MD5; };
1320    if( $@ )
1321    {
1322      die "no Digest::MD5";
1323    }
1324    my $enc_hex  = substr($enc, 0, 32);
1325    my $enc_salt = pack("H*",substr($enc, 32));
1326    my $cmp = Digest::MD5::md5_hex($plain.$enc_salt);
1327    return $cmp eq lc($enc_hex);
1328  }elsif( $type =~ /^(RAW)\z/ )
1329  {
1330    return $enc eq $plain;
1331  }elsif( $type =~ /^(CRYPT)\z/ )
1332  {
1333    my $cmp = crypt($plain,substr($enc,0,2));
1334    if( length($plain) > 8 )
1335    {
1336      my $cmp2 = crypt(substr($plain, 0, 8),substr($enc,0,2));
1337      if( $cmp eq $cmp2 )
1338      {
1339        die "CRYPT supports upto 8 bytes";
1340        return;
1341      }
1342    }
1343    return $cmp eq $enc;
1344  }else
1345  {
1346    die "unsupported packed value, type=$type";
1347  }
1348}
1349
1350# -----------------------------------------------------------------------------
1351# $bool = $this->_can_show($req, $ch_short, $netname).
1352# 閲覧可能かの判定.
1353# 存在するかどうかは別途確認が必要.
1354#
1355sub _can_show
1356{
1357  my $this = shift;
1358  my $req  = shift;
1359  my $ch_short  = shift;
1360  my $netname   = shift;
1361  my $conflist = $req->{conflist};
1362
1363  my $ch_full = Multicast::attach($ch_short, $netname);
1364  foreach my $allow (@$conflist)
1365  {
1366    my $ok = Mask::match_deep($allow->{masks}, $ch_full);
1367    $DEBUG and $this->_debug("- can_show: $netname / $ch_short = ".($ok?"ok":"ng")." mask: ".join(", ",@{$allow->{masks}}));
1368    if( $ok )
1369    {
1370      return $ok;
1371    }
1372  }
1373  return; # false.
1374}
1375
1376# -----------------------------------------------------------------------------
1377# $html = $this->_gen_list($req).
1378#
1379sub _gen_list
1380{
1381  my $this = shift;
1382  my $req  = shift;
1383
1384  my $peerhost = $req->{peerhost};
1385  my $conflist = $req->{conflist};
1386
1387  my $show_all;
1388  if( my $show = $this->_get_cgi_hash($req)->{show} )
1389  {
1390    $show_all = $show eq 'all';
1391  }
1392
1393  # 表示できるネットワーク＆チャンネルを抽出.
1394  #
1395  my %channels;
1396  foreach my $netname (keys %{$this->{cache}})
1397  {
1398    foreach my $ch_short (keys %{$this->{cache}{$netname}})
1399    {
1400      my $ok = $this->_can_show($req, $ch_short, $netname);
1401      if( $ok )
1402      {
1403        my $cache  = $this->{cache}{$netname}{$ch_short};
1404        my $pack = {
1405          disp_netname  => $netname,
1406          disp_ch_short => $ch_short,
1407          anchor        => undef,
1408          unseen        => undef,
1409          unseen_plus   => undef,
1410        };
1411
1412        my $recent = $cache->{recent} || [];
1413        my $seen = $req->{session}{seen}{$netname}{$ch_short} || 0;
1414        my $nr_unseen = 0;
1415        foreach my $r (reverse @$recent)
1416        {
1417          $r == $seen and last;
1418          ++$nr_unseen;
1419        }
1420
1421        $pack->{unseen} = $nr_unseen;
1422        if( $nr_unseen == $this->{max_lines}{''} && $recent->[0] != $seen )
1423        {
1424          $pack->{unseen_plus} = 1;
1425        }
1426
1427        if( $seen )
1428        {
1429          $pack->{anchor} = "L.$seen->{ymd}.$seen->{lineno}";
1430        }
1431
1432        if( $nr_unseen > 0 || $show_all )
1433        {
1434          push(@{$channels{$netname}}, $pack);
1435        }
1436      }
1437    }
1438  }
1439  # 別のTiarraさんのネットワークを解凍(設定があったとき).
1440  my %new_channels;
1441  foreach my $extract_line ( $this->config->extract_network('all') )
1442  {
1443    my ($extract, $sep) = split(' ', $extract_line);
1444    $sep ||= '@';
1445    my $list = delete $channels{$extract} or next;
1446    foreach my $pack (@$list)
1447    {
1448      my $ch_long = $pack->{disp_ch_short};
1449      my ($ch_short, $netname, $is_explicit) = $this->_detach($ch_long, $sep);
1450      if( !$is_explicit )
1451      {
1452        # wrong separator?
1453        next;
1454      }
1455      if( $channels{$netname} && !$new_channels{$netname} )
1456      {
1457        # no merge.
1458        next;
1459      }
1460      $pack->{disp_netname}  = $netname;
1461      $pack->{disp_ch_short} = $ch_short;
1462      push(@{$new_channels{$netname}}, $pack);
1463    }
1464  }
1465  %channels = (%channels, %new_channels);
1466
1467  # ネットワーク＆チャンネルの一覧をHTML化.
1468  #
1469  my $is_pc = $req->{ua_type} eq 'pc';
1470  my $content = "";
1471  $content .= $is_pc ? "<ul>\n" : "<div>\n";
1472  if( keys %channels )
1473  {
1474    foreach my $netname (sort keys %channels)
1475    {
1476      if( $is_pc )
1477      {
1478        $content .= "<li> $netname\n";
1479        $content .= "  <ul>\n";
1480      }else
1481      {
1482        $content .= "[$netname]<br />\n";
1483      }
1484      my @channels = @{$channels{$netname}};
1485      @channels = sort {$a->{disp_ch_short} cmp $b->{disp_ch_short}} @channels;
1486      my $seqno = 0;
1487      foreach my $pack (@channels)
1488      {
1489        my $channame = $pack->{disp_ch_short};
1490        ++$seqno;
1491        my $link_ch = $channame;
1492        if( $link_ch =~ s/^#// )
1493        {
1494          # normal channels.
1495        }elsif( $link_ch =~ s/^![0-9A-Z]{5}/!/ )
1496        {
1497          # channel    =  ( "#" / "+" / ( "!" channelid ) / "&" ) chanstring [ ":" chanstring ]
1498          # channelid  = 5( %x41-5A / digit )   ; 5( A-Z / 0-9 )
1499          # (RFC2812)
1500        }else
1501        {
1502          $link_ch = "=$link_ch";
1503        }
1504        my $link = "log\0$netname\0$link_ch\0";
1505        $link =~ s{/}{%252F}g;
1506        $link =~ tr{\0}{/};
1507        $link = $this->_escapeHTML($link);
1508
1509        my $unseen;
1510        if( !$pack->{unseen} )
1511        {
1512          $unseen = '';
1513        }else
1514        {
1515          my $nr_unseen = $pack->{unseen};
1516          my $plus      = $pack->{unseen_plus} ? '+' : '';
1517          $unseen = " ($nr_unseen$plus)";
1518        }
1519
1520        my $channame_label = $this->_escapeHTML($channame);
1521        $channame_label =~ s/^![0-9A-Z]{5}/!/;
1522        my $ref = $pack->{anchor} ? "?x=$pack->{anchor}" : '';
1523        if( $is_pc )
1524        {
1525          $content .= qq{    <li><a href="$link$ref">$channame_label</a>$unseen</li>\n};
1526        }else
1527        {
1528          $content .= qq{$seqno. <a href="$link$ref">$channame_label</a>$unseen<br />\n};
1529        }
1530      }
1531      if( $is_pc )
1532      {
1533        $content .= "  </ul>\n";
1534        $content .= "</li>\n";
1535      }
1536    }
1537  }else
1538  {
1539    $content = $is_pc ? "<li>no channels</li>\n" : "no channels\n";
1540  }
1541  $content .= $is_pc ? "</ul>\n" : "<div\n>";
1542
1543  my $shared_box = '';
1544  my $mode = $this->_get_req_param($req, 'mode');
1545  if( $mode ne 'owner' )
1546  {
1547    $shared_box .= "<br />\n";
1548    $shared_box .= "[\n";
1549    $shared_box .= qq{<a href="config">設定</a>\n};
1550    $shared_box .= "|\n";
1551    $shared_box .= qq{<a href="logout">ログアウト</a>\n};
1552    $shared_box .= "]\n";
1553  }
1554  my $tmpl = $this->_gen_list_html();
1555  $this->_expand($req, $tmpl, {
1556    CONTENT => $content,
1557    SHOW_TOGGLE_LABEL => $show_all ? 'MiniList' : 'ShowAll',
1558    SHOW_TOGGLE_VALUE => $show_all ? 'updated' : 'all',
1559    SHARED_BOX => $shared_box,
1560  });
1561}
1562sub _gen_list_html
1563{
1564  <<HTML;
1565<?xml version="1.0" encoding="utf-8" ?>
1566<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
1567<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="ja-JP">
1568<head>
1569  <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1570  <meta http-equiv="Content-Style-Type"  content="text/css" />
1571  <meta http-equiv="Content-Script-Type" content="text/javascript" />
1572  <link rel="stylesheet" type="text/css" href="<&CSS>" />
1573  <title>channels</title>
1574</head>
1575<body>
1576<div class="main">
1577<div class="uatype-<&UA_TYPE>">
1578
1579<h1>channels</h1>
1580
1581<&CONTENT>
1582
1583<form action="./" method="post">
1584ENTER: <input type="text" name="enter" value="" />
1585<input type="submit" value="入室" /><br />
1586</form>
1587
1588<p>
1589[
1590<a href="./" accesskey="0">再表示</a>[0] |
1591<a href="./?show=<&SHOW_TOGGLE_VALUE>" accesskey="#"><&SHOW_TOGGLE_LABEL></a>[#]
1592]
1593<&SHARED_BOX>
1594</p>
1595
1596</div>
1597</div>
1598</body>
1599</html>
1600HTML
1601}
1602
1603sub _post_list
1604{
1605  my $this = shift;
1606  my $req  = shift;
1607
1608  my $cgi = $this->_get_cgi_hash($req);
1609  if( my $ch_long = $cgi->{enter} )
1610  {
1611    my ($ch_short, $netname) = Multicast::detach($ch_long);
1612    if( !$this->_can_show($req, $ch_short, $netname) )
1613    {
1614      return;
1615    }
1616    my $network  = $this->_runloop->network($netname);
1617    if( $network )
1618    {
1619      $this->{cache}{$netname}{$ch_short} ||= $this->_new_cache_entry($netname, $ch_short);
1620      $DEBUG and $this->_debug("enter: $netname/$ch_short");
1621      my $link_ch = $ch_short;
1622      $link_ch =~ s/^#// or $link_ch = "=$link_ch";
1623      my $link = "log\0$netname\0$link_ch\0";
1624      $link =~ s{/}{%2F}g;
1625      $link =~ tr{\0}{/};
1626      $this->_location($req, $link);
1627      return 1;
1628    }
1629  }
1630  return undef;
1631}
1632
1633sub _expand
1634{
1635  my $this = shift;
1636  my $req  = shift;
1637  my $tmpl = shift;
1638  my $vars = shift;
1639
1640  my $top_path_esc  = $this->_escapeHTML($this->{path});
1641  my $css_esc       = $this->_escapeHTML($this->config->css || "$this->{path}style/style.css");
1642  my $site_name_esc = $this->_escapeHTML($this->config->site_name || $DEFAULT_SITE_NAME);
1643  $req->{ua_type} =~ /^\w+\z/ or die "invalid ua_type: [$req->{ua_type}]";
1644  my $common_vars = {
1645    TOP_PATH  => $top_path_esc,
1646    CSS       => $css_esc,
1647    UA_TYPE   => $req->{ua_type},
1648    SITE_NAME => $site_name_esc,
1649  };
1650
1651  $tmpl =~ s{<&(.*?)>}{
1652    my $key = $1;
1653    if( defined($vars->{$key}) )
1654    {
1655      $vars->{$key};
1656    }elsif( defined($common_vars->{$key}) )
1657    {
1658      $common_vars->{$key};
1659    }else
1660    {
1661      die "unexpanded key: $key";
1662    }
1663  }ge;
1664
1665  $tmpl;
1666}
1667
1668# -----------------------------------------------------------------------------
1669# $html = $this->_gen_log($req, $netname, $ch_short).
1670#
1671sub _gen_log
1672{
1673  my $this = shift;
1674  my $req  = shift;
1675  my $netname  = shift;
1676  my $ch_short = shift;
1677
1678  # cacheにはいっているのと閲覧許可があるのは確認済.
1679
1680  my $content = "";
1681
1682  if( my $net = $this->_runloop->network($netname) )
1683  {
1684    if( my $chan = $net->channel($ch_short) )
1685    {
1686      my $topic = $chan->topic || '(no-topic)';
1687      my $topic_esc = $this->_escapeHTML($topic);
1688      $content .= "<p>\n";
1689      $content .= "<span class=\"chan-topic\">TOPIC: $topic_esc</span><br />\n";
1690      $content .= "</p>\n";
1691    }
1692  }
1693
1694  my $cache  = $this->{cache}{$netname}{$ch_short};
1695  my $recent = $cache->{recent};
1696  my $cgi    = $this->_get_cgi_hash($req);
1697
1698  # 表示位置の探索.
1699  my $show_lines = $DEFAULT_SHOW_LINES;
1700  my $rindex;
1701  if( my $rtoken = $cgi->{r} )
1702  {
1703    my $re = qr/\Q$rtoken\E\z/;
1704    my $ymd = '-';
1705    foreach my $i (0..$#$recent)
1706    {
1707      my $info = $recent->[$i];
1708      if( $ymd ne $info->{ymd} )
1709      {
1710        $ymd = $info->{ymd};
1711        my $anchor = "L.$ymd";
1712        if( $anchor =~ $re )
1713        {
1714          $rindex = $i;
1715          last;
1716        }
1717      }
1718      my $anchor = "L.$ymd.$info->{lineno}";
1719      if( $anchor =~ $re )
1720      {
1721        $rindex = $i;
1722        last;
1723      }
1724    }
1725  }else
1726  {
1727    if( @$recent > $show_lines )
1728    {
1729      $rindex = @$recent - $show_lines;
1730    }
1731  }
1732  $rindex ||= 0;
1733  # $rindex も含めてindex系は [0..$#$recent] の範囲の値.
1734  if( my $xtoken = $cgi->{x} )
1735  {
1736    my $re = qr/\Q$xtoken\E\z/;
1737    foreach my $i ($rindex..$#$recent )
1738    {
1739      my $info = $recent->[$i];
1740      my $anchor = "L.$info->{ymd}.$info->{lineno}";
1741      if( $anchor =~ $re )
1742      {
1743        if( $i < $#$recent )
1744        {
1745          $rindex = $i + 1;
1746        }else
1747        {
1748          $rindex = $#$recent;
1749        }
1750        last;
1751      }
1752    }
1753  }
1754
1755  my $last;
1756  if( $rindex + $show_lines > @$recent )
1757  {
1758    $last = $#$recent;
1759  }else
1760  {
1761    $last = $rindex + $show_lines - 1;
1762  }
1763
1764  # 既読情報の更新.
1765  my $last_seen_index;
1766  if( my $cur = $req->{session}{seen}{$netname}{$ch_short} )
1767  {
1768    foreach my $i ($last+1 .. $#$recent)
1769    {
1770      if( $recent->[$i] == $cur )
1771      {
1772        $last_seen_index = $i;
1773        last;
1774      }
1775    }
1776  }
1777  if( !defined($last_seen_index) )
1778  {
1779    $last_seen_index = $last;
1780    my $last_seen = @$recent ? $recent->[$last] : undef;
1781    $req->{session}{seen}{$netname}{$ch_short} = $last_seen;
1782  }
1783
1784  my $next_index = $last < $#$recent ? $last + 1 : $#$recent;
1785  my $prev_index = $rindex < $show_lines ? 0 : ($rindex - $show_lines);
1786  my ($next_rtoken, $prev_rtoken, $last_seen_rtoken) = map {
1787    my $i = $_;
1788    my $info = @$recent ? $recent->[$i] : {ymd=>'-00',lineno=>0};
1789    my $anchor = "L.$info->{ymd}.$info->{lineno}";
1790    $anchor =~ s/.*-//;
1791    $anchor;
1792  } $next_index, $prev_index, $last_seen_index;
1793
1794  my $nr_cached_lines = @$recent;
1795  my $lines2 = $nr_cached_lines==1 ? 'line' : 'lines';
1796  $recent = [ @$recent [ $rindex .. $last ] ];
1797
1798  my $navi_raw = '';
1799  if( @$recent )
1800  {
1801    my $sort_order = $this->_get_req_param($req, 'sort-order');
1802    $DEBUG and $this->_debug("sort_order = $sort_order");
1803    if( $sort_order ne 'asc' )
1804    {
1805      @$recent = reverse @$recent;
1806    }
1807    my $nr_recent = @$recent;
1808    my $lines    = $nr_recent==1 ? 'line' : 'lines';
1809    $navi_raw .= "<p>";
1810    $navi_raw .= "$nr_recent $lines / $nr_cached_lines $lines2.<br />";
1811    $navi_raw .= qq{[ <b><a href="?r=$prev_rtoken" accesskey="7">&lt;&lt;</a></b>[7] |};
1812    $navi_raw .= qq{  <b><a href="?r=$next_rtoken" accesskey="9">&gt;&gt;</a></b>[9] ]\n};
1813    $navi_raw .= "</p>";
1814
1815    my $ymd = '-'; # first entry should be displayed.
1816    $content .= "<pre>";
1817    foreach my $info (@$recent)
1818    {
1819      if( $ymd ne $info->{ymd} )
1820      {
1821        $ymd = $info->{ymd};
1822        my $anchor = "L.$ymd";
1823        my $rtoken = $ymd;
1824        $content .= qq{[<b><a id="$anchor" href="?r=$rtoken">$ymd</a></b>]\n};
1825      }
1826      my $line_html = $this->_escapeHTML($info->{formatted});
1827      if( $req->{ua_type} ne 'pc' )
1828      {
1829        $line_html =~ s/^(\d\d:\d\d):\d\d /$1 /;
1830      }
1831      my $anchor = "L.$ymd.$info->{lineno}";
1832      my $rtoken = $anchor;
1833      $rtoken =~ s/.*-//;
1834      $content .= qq{<a id="$anchor" href="?r=$rtoken">$info->{lineno}</a>/$line_html\n};
1835    }
1836    $content .= "</pre>\n";
1837  }else
1838  {
1839    $content .= "<p>\n";
1840    $content .= "no lines.";
1841    $content .= "</p>\n";
1842  }
1843
1844  my $ch_long = Multicast::attach($ch_short, $netname);
1845  $ch_long =~ s/^![0-9A-Z]{5}/!/;
1846  my $ch_long_esc = $this->_escapeHTML($ch_long);
1847  my $name_esc = $this->_escapeHTML($req->{session}{name} || '');
1848
1849  my $mode = $this->_get_req_param($req, 'mode');
1850  my $name_marker_raw = '';
1851  if( $mode ne 'owner' )
1852  {
1853    $name_marker_raw = qq{$name_esc&gt; };
1854  }
1855
1856  my $h1_ch_long_raw;
1857  if( $req->{ua_type} eq 'pc' )
1858  {
1859    $h1_ch_long_raw = "<h1>$ch_long_esc</h1>";
1860  }else
1861  {
1862    $h1_ch_long_raw = "<b>$ch_long_esc</b>";
1863  }
1864
1865  my $tmpl = $this->_gen_log_html();
1866  $this->_expand($req, $tmpl, {
1867    CONTENT_RAW => $content,
1868    NAVI_RAW    => $navi_raw,
1869    CH_LONG => $ch_long_esc,
1870    H1_CH_LONG_RAW => $h1_ch_long_raw,
1871    NAME    => $name_esc,
1872    NAME_MARKER_RAW => $name_marker_raw,
1873    RTOKEN  => $next_rtoken,
1874    NEXT_RTOKEN => $next_rtoken,
1875    PREV_RTOKEN => $prev_rtoken,
1876    LAST_SEEN_RTOKEN => $last_seen_rtoken,
1877  });
1878}
1879sub _gen_log_html
1880{
1881  <<HTML;
1882<?xml version="1.0" encoding="utf-8" ?>
1883<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
1884<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="ja-JP">
1885<head>
1886  <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1887  <meta http-equiv="Content-Style-Type"  content="text/css" />
1888  <meta http-equiv="Content-Script-Type" content="text/javascript" />
1889  <link rel="stylesheet" type="text/css" href="<&CSS>" />
1890  <title><&CH_LONG></title>
1891</head>
1892<body>
1893<div class="main">
1894<div class="uatype-<&UA_TYPE>">
1895
1896<&H1_CH_LONG_RAW>
1897
1898<&CONTENT_RAW>
1899
1900<form action="./" method="post">
1901<p>
1902talk:<&NAME_MARKER_RAW><input type="text" name="m" size="60" />
1903  <input type="submit" value="発言/更新" /><br />
1904<input type="hidden" name="x" size="10" value="<&LAST_SEEN_RTOKEN>" />
1905</p>
1906</form>
1907
1908<&NAVI_RAW>
1909
1910<p>
1911[
1912<a href="./?x=<&LAST_SEEN_RTOKEN>" accesskey="*">更新</a>[*] |
1913<a href="<&TOP_PATH>" accesskey="0">List</a>[0] |
1914<a href="info" accesskey="#">info</a>[#]
1915]
1916</p>
1917
1918</div>
1919</div>
1920</body>
1921</html>
1922HTML
1923}
1924
1925sub _get_req_param
1926{
1927  my $this = shift;
1928  my $req  = shift;
1929  my $key  = shift;
1930
1931  if( !grep{ $key eq $_ } qw(mode sort-order) )
1932  {
1933    die "invalid req-param [$key]";
1934  }
1935  if( $req->{req_param}{$key} )
1936  {
1937    return $req->{req_param}{$key};
1938  }
1939
1940  my $val;
1941  foreach my $allow (@{$req->{conflist}})
1942  {
1943    $val = $allow->{block}->$key;
1944    $val or next;
1945    $DEBUG and $this->_debug(__PACKAGE__."#_gen_log, $key = $val (by $allow->{name})");
1946    last;
1947  }
1948  $val ||= $this->config->$key;
1949  if( $key eq 'mode' )
1950  {
1951    $val ||= 'owner';
1952    if( $val !~ /^(?:owner|shared)\z/ )
1953    {
1954      $val = 'owner';
1955    }
1956  }
1957  if( $key eq 'sort-order' )
1958  {
1959    $val ||= 'asc';
1960    $val = $val =~ /^(?:desc|rev)/ ? 'desc' : 'asc';
1961  }
1962
1963  $req->{req_param}{$key} = $val;
1964  $val;
1965}
1966
1967sub _get_cgi_hash
1968{
1969  my $this = shift;
1970  my $req  = shift;
1971
1972  if( $req->{cgi_hash} )
1973  {
1974    return $req->{cgi_hash};
1975  }
1976
1977  my $cgi = {};
1978
1979  if( $req->{Method} eq 'GET' )
1980  {
1981    if( $req->{Path} =~ m{\?} )
1982    {
1983      (undef,my $query) = split(/\?/, $req->{Path});
1984      foreach my $pair (split(/[&;]/, $query))
1985      {
1986        my ($key, $val) = split(/=/, $pair, 2);
1987        $val =~ s/%([0-9a-f]{2})/pack("H*",$1)/gie;
1988        $cgi->{$key} = $val;
1989      }
1990    }
1991  }
1992
1993  if( $req->{Method} eq 'POST' )
1994  {
1995    foreach my $pair (split(/[&;]/, $req->{Content}))
1996    {
1997      my ($key, $val) = split(/=/, $pair, 2);
1998      $val =~ s/%([0-9a-f]{2})/pack("H*",$1)/gie;
1999      $cgi->{$key} = $val;
2000    }
2001  }
2002
2003  $req->{cgi_hash} = $cgi;
2004  $cgi;
2005}
2006
2007sub _post_log
2008{
2009  my $this = shift;
2010  my $req  = shift;
2011  my $netname  = shift;
2012  my $ch_short = shift;
2013
2014  my $mode = $this->_get_req_param($req, 'mode');
2015
2016  my $cgi = $this->_get_cgi_hash($req);
2017  if( my $m = $cgi->{m} )
2018  {
2019    if( $mode ne 'owner' )
2020    {
2021      my $name = $req->{session}{name} or die "no session.name";
2022      $m = "$name> $m";
2023    }
2024    $m =~ s/[\r\n].*//s;
2025    my $network = RunLoop->shared_loop->network($netname);
2026    if( $network )
2027    {
2028      my $channel = $network->channel($ch_short);
2029      if( $channel || !Multicast::channel_p($ch_short) )
2030      {
2031        my $msg_to_send = Auto::Utils->construct_irc_message(
2032          Command => 'PRIVMSG',
2033          Params  => [ '', $m ],
2034        );
2035
2036        # send to server.
2037        #
2038        {
2039          my $for_server = $msg_to_send->clone;
2040          $for_server->param(0, $ch_short);
2041          $network->send_message($for_server);
2042        }
2043
2044        # send to clients.
2045        #
2046        my $ch_on_client = Multicast::attach_for_client($ch_short, $netname);
2047        my $for_client = $msg_to_send->clone;
2048        $for_client->param(0, $ch_on_client);
2049        $for_client->remark('fill-prefix-when-sending-to-client', 1);
2050        RunLoop->shared_loop->broadcast_to_clients($for_client);
2051      }else
2052      {
2053        RunLoop->shared_loop->notify_error("no such channel [$ch_short] on network [$netname]");
2054      }
2055    }else
2056    {
2057      RunLoop->shared_loop->notify_error("no network to talk: $netname");
2058    }
2059  }
2060  return undef;
2061}
2062
2063# -----------------------------------------------------------------------------
2064# $html = $this->_gen_chan_info($req, $netname, $ch_short).
2065#
2066sub _gen_chan_info
2067{
2068  my $this = shift;
2069  my $req  = shift;
2070  my $netname  = shift;
2071  my $ch_short = shift;
2072
2073  my $content_raw = "";
2074
2075  my ($topic_esc, $names_esc);
2076  if( my $net = $this->_runloop->network($netname) )
2077  {
2078    if( my $chan = $net->channel($ch_short) )
2079    {
2080      my $topic = $chan->topic || '(none)';
2081      my $names = $chan->names || {};
2082      $names = [ values %$names ];
2083      @$names = map{
2084        my $pic = $_; # $pic :: PersonInChannel.
2085        my $nick  = $pic->person->nick;
2086        my $sigil = $pic->priv_symbol;
2087        "$sigil$nick";
2088      } @$names;
2089      @$names = sort @$names;
2090      $topic_esc = $this->_escapeHTML($topic);
2091      $names_esc = $this->_escapeHTML(join(' ', @$names));
2092    }
2093  }else
2094  {
2095  }
2096  $topic_esc ||= '-';
2097  $names_esc ||= '-';
2098
2099  my $in_topic_esc;
2100  my $cgi = $this->_get_cgi_hash($req);
2101  if( my $in_topic = $cgi->{topic} )
2102  {
2103    $in_topic_esc = $this->_escapeHTML($in_topic);
2104  }else
2105  {
2106    $in_topic_esc = $topic_esc;
2107  }
2108
2109  my $ch_long = Multicast::attach($ch_short, $netname);
2110  $ch_long =~ s/^![0-9A-Z]{5}/!/;
2111  my $ch_long_esc = $this->_escapeHTML($ch_long);
2112
2113  my $tmpl = $this->_tmpl_chan_info();
2114  $this->_expand($req, $tmpl, {
2115    CONTENT_RAW => $content_raw,
2116    CH_LONG   => $ch_long_esc,
2117    TOPIC     => $topic_esc,
2118    IN_TOPIC  => $in_topic_esc,
2119    NAMES     => $names_esc,
2120    PART_MSG  => 'Leaving...',
2121  });
2122}
2123sub _tmpl_chan_info
2124{
2125  <<HTML;
2126<?xml version="1.0" encoding="utf-8" ?>
2127<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
2128<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="ja-JP">
2129<head>
2130  <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
2131  <meta http-equiv="Content-Style-Type"  content="text/css" />
2132  <meta http-equiv="Content-Script-Type" content="text/javascript" />
2133  <link rel="stylesheet" type="text/css" href="<&CSS>" />
2134  <title><&CH_LONG></title>
2135</head>
2136<body>
2137<div class="main">
2138<div class="uatype-<&UA_TYPE>">
2139
2140<h1><&CH_LONG></h1>
2141
2142<&CONTENT_RAW>
2143
2144<form action="./info" method="post">
2145TOPIC: <span class="chan-topic"><&TOPIC></span><br />
2146<input type="text" name="topic" value="<&IN_TOPIC>" />
2147<input type="submit" value="変更" /><br />
2148</form>
2149
2150<p>
2151NAMES: <span class="chan-names"><&NAMES></span><br />
2152</p>
2153
2154<form action="./info" method="post">
2155PART: <input type="text" name="part" value="<&PART_MSG>" />
2156<input type="submit" value="退室" /><br />
2157</form>
2158
2159<form action="./info" method="post">
2160JOIN <input type="hidden" name="join" value="<&CH_LONG>" />
2161<input type="submit" value="入室" /><br />
2162</form>
2163
2164<form action="./info" method="post">
2165DELETE <input type="hidden" name="delete" value="<&CH_LONG>" />
2166<input type="submit" value="削除" /><br />
2167</form>
2168
2169<p>
2170[
2171<a href="./" accesskey="*">戻る</a>[*] |
2172<a href="<&TOP_PATH>" accesskey="0">List</a>[0] |
2173<a href="info" accesskey="#">再表示</a>[#]
2174]
2175</p>
2176
2177</div>
2178</div>
2179</body>
2180</html>
2181HTML
2182}
2183
2184sub _post_chan_info
2185{
2186  my $this = shift;
2187  my $req  = shift;
2188  my $netname  = shift;
2189  my $ch_short = shift;
2190
2191  my $cgi = $this->_get_cgi_hash($req);
2192  if( exists($cgi->{topic}) )
2193  {
2194    my $msg_to_send = Auto::Utils->construct_irc_message(
2195      Command => 'TOPIC',
2196      Params  => [ '', $cgi->{topic} ],
2197    );
2198
2199    # send to server.
2200    #
2201    my $network = RunLoop->shared_loop->network($netname);
2202    if( $network )
2203    {
2204      my $for_server = $msg_to_send->clone;
2205      $for_server->param(0, $ch_short);
2206      $network->send_message($for_server);
2207    }
2208  }
2209
2210  if( exists($cgi->{part}) )
2211  {
2212    my $msg_to_send = Auto::Utils->construct_irc_message(
2213      Command => 'PART',
2214      Params  => [ '', $cgi->{part} ],
2215    );
2216
2217    # send to server.
2218    #
2219    my $network = RunLoop->shared_loop->network($netname);
2220    if( $network )
2221    {
2222      my $for_server = $msg_to_send->clone;
2223      $for_server->param(0, $ch_short);
2224      $network->send_message($for_server);
2225    }
2226  }
2227
2228  if( exists($cgi->{join}) )
2229  {
2230    my $msg_to_send = Auto::Utils->construct_irc_message(
2231      Command => 'JOIN',
2232      Params  => [ '' ],
2233    );
2234
2235    # send to server.
2236    #
2237    my $network = RunLoop->shared_loop->network($netname);
2238    if( $network )
2239    {
2240      my $for_server = $msg_to_send->clone;
2241      $for_server->param(0, $ch_short);
2242      $network->send_message($for_server);
2243    }
2244  }
2245
2246  if( exists($cgi->{'delete'}) )
2247  {
2248    delete $this->{cache}{$netname}{$ch_short};
2249    if( !keys %{$this->{cache}{$netname}} )
2250    {
2251      delete $this->{cache}{$netname};
2252    }
2253    $this->_location($req, "/");
2254    return 1;
2255  }
2256
2257  return undef;
2258}
2259
2260# -----------------------------------------------------------------------------
2261# $html = $this->_gen_config($req).
2262#
2263sub _gen_config
2264{
2265  my $this = shift;
2266  my $req  = shift;
2267
2268  my $name_esc = $this->_escapeHTML( $req->{session}{name} || '' );
2269
2270  my $tmpl = $this->_tmpl_config();
2271  $this->_expand($req, $tmpl, {
2272    NAME      => $name_esc,
2273  });
2274}
2275sub _tmpl_config
2276{
2277  <<HTML;
2278<?xml version="1.0" encoding="utf-8" ?>
2279<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
2280<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="ja-JP">
2281<head>
2282  <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
2283  <meta http-equiv="Content-Style-Type"  content="text/css" />
2284  <meta http-equiv="Content-Script-Type" content="text/javascript" />
2285  <link rel="stylesheet" type="text/css" href="<&CSS>" />
2286  <title>設定</title>
2287</head>
2288<body>
2289<div class="main">
2290<div class="uatype-<&UA_TYPE>">
2291
2292<h1>設定</h1>
2293
2294<form action="./config" method="post">
2295名前: <input type="text" name="n" value="<&NAME>" /><br />
2296<input type="submit" value="変更" /><br />
2297</form>
2298
2299<p>
2300[
2301<a href="./" accesskey="*">戻る</a>[*] |
2302<a href="<&TOP_PATH>" accesskey="0">List</a>[0] |
2303<a href="config" accesskey="#">再表示</a>[#]
2304]
2305</p>
2306
2307</div>
2308</div>
2309</body>
2310</html>
2311HTML
2312}
2313
2314sub _post_config
2315{
2316  my $this = shift;
2317  my $req  = shift;
2318
2319  my $cgi = $this->_get_cgi_hash($req);
2320  if( $cgi->{n} )
2321  {
2322    $req->{session}{name} = $cgi->{n};
2323  }
2324
2325  return undef;
2326}
2327
2328
2329# -----------------------------------------------------------------------------
2330# $txt = $this->_escapeHTML($html).
2331#
2332sub _escapeHTML
2333{
2334  my $this = shift;
2335  Tools::HTTPParser->escapeHTML(@_);
2336}
2337
2338# ($ch_short, $net_name, $explicit) = $this->_detach($ch_long, $sep);
2339# $ch_short = $this->_detach($ch_long, $sep);
2340sub _detach {
2341    my $this = shift;
2342    my $str  = shift;
2343    my $sep  = shift;
2344
2345    if (!defined $str) {
2346        die "Arg[0] was undef.\n";
2347    }
2348    elsif (ref($str) ne '') {
2349        die "Arg[0] was ref.\n";
2350    }
2351
2352    my @result;
2353    if ((my $sep_index = index($str,$sep)) != -1) {
2354        my $before_sep = substr($str,0,$sep_index);
2355        my $after_sep = substr($str,$sep_index+length($sep));
2356        if ((my $colon_pos = index($after_sep,':')) != -1) {
2357            # #さいたま@taiyou:*.jp  →  #さいたま:*.jp + taiyou
2358            @result = ($before_sep.substr($after_sep,$colon_pos),
2359                       substr($after_sep,0,$colon_pos),
2360                       1);
2361        }
2362        else {
2363            # #さいたま@taiyou  →  #さいたま + taiyou
2364            @result = ($before_sep,$after_sep,1);
2365        }
2366    }
2367    else {
2368        @result = ($str,$this->_runloop->default_network,undef);
2369    }
2370    return wantarray ? @result : $result[0];
2371}
2372
2373sub _attach {
2374    # $strはChannelInfoのオブジェクトでも良い。
2375    # $network_nameは省略可能。IrcIO::Serverのオブジェクトでも良い。
2376    my $this = shift;
2377    my $str  = shift;
2378    my $network_name = shift;
2379    my $separator    = shift;
2380
2381    if (ref($str) eq 'ChannelInfo') {
2382        $str = $str->name;
2383    }
2384    if (ref($network_name) eq 'IrcIO::Server') {
2385        $network_name = $network_name->network_name;
2386    }
2387
2388    if (!defined $str) {
2389        die "Arg[0] was undef.\n";
2390    }
2391    elsif (ref($str) ne '') {
2392        die "Arg[0] was ref.\n";
2393    }
2394
2395    $network_name = $this->_runloop->default_network if $network_name eq '';
2396    if ((my $pos_colon = index($str,':')) != -1) {
2397        # #さいたま:*.jp  →  #さいたま@taiyou:*.jp
2398        $str =~ s/:/$separator.$network_name.':'/e;
2399    }
2400    else {
2401        # #さいたま  →  #さいたま@taiyou
2402        $str .= $separator.$network_name;
2403    }
2404    $str;
2405}
2406# -----------------------------------------------------------------------------
2407# End of Module.
2408# -----------------------------------------------------------------------------
2409# -----------------------------------------------------------------------------
2410# End of File.
2411# -----------------------------------------------------------------------------
2412__END__
2413
2414=encoding utf8
2415
2416=for stopwords
2417        YAMASHINA
2418        Hio
2419        ACKNOWLEDGEMENTS
2420        AnnoCPAN
2421        CPAN
2422        RT
2423
2424package System::WebClient;
2425
2426=begin tiarra-doc
2427
2428info:    ブラウザ上でログを見たり発言したりできます.
2429default: off
2430#section: important
2431
2432# WebClient を起動させる場所の指定.
2433bind-addr: 127.0.0.1
2434bind-port: 8668
2435path: /irc
2436css:  /style/irc-style.css
2437# 上の設定をapacheでReverseProxyさせる場合, httpd.conf には次のように設定.
2438#  ProxyPass        /irc/ http://localhost:8667/irc/
2439#  ProxyPassReverse /irc/ http://localhost:8667/irc/
2440#  <Location /irc/>
2441#  ...
2442#  </Location>
2443
2444# ReverseProxy 利用時の追加設定.
2445# 接続元が全部プロキシサーバになっちゃうのでその対応.
2446# ReverseProxy 使わず直接公開の場合は不要.
2447-extract-forwarded-for: 127.0.0.1
2448
2449# 利用する接続設定の一覧.
2450#
2451# 空白区切りで評価する順に記述.
2452# 使われる設定は,
2453# - 接続元 IP が一致する物.
2454# - user/passが送られてきていない(認証前/anonymous):
2455#   - 認証不要の設定があればその設定を利用.
2456#   - 認証不要の設定がなければ 401 Unauthorized.
2457# - user/passが送られてきている.
2458#   - 一致する設定を利用.
2459#   - 一致する設定がなければ 401 Unauthorized.
2460allow: private public
2461
2462# 許可する接続の設定.
2463allow-private {
2464  # 接続元IPアドレスの制限.
2465  host: 127.0.0.1
2466  # 認証設定.
2467  # auth: <user> <pass>
2468  # auth: :basic <user> <pass>
2469  # auth: :softbank <端末ID>
2470  # auth: :softbank <UID>
2471  # auth: :au <SUBNO>
2472  # 各値(<pass>等)には {MD5}xxxx や {B}xxx や {CRYPT}xxx を利用可能.
2473  # そのままべた書きも出来るけれど.
2474  auth: :basic user pass
2475  # 公開するチャンネルの指定.
2476  mask: #*@*
2477  mask: *@*
2478}
2479allow-public {
2480  host: *
2481  auth: user2 pass2
2482  mask: #公開チャンネル@ircnet
2483}
2484
2485# デバッグフラグ.
2486-debug: 0
2487
2488# 保存する最大行数.
2489-max-lines:    100
2490
2491# クライアントモード.
2492# owner か shared.
2493- mode: owner
2494
2495# ログの方向.
2496# asc (旧->新) か desc (新->旧).
2497- sort-order: asc
2498
2499# name-default 設定は VERSION 0.05 で廃止されました.
2500# # 発言BOXで名前指定しなかったときのデフォルトの名前.
2501# # mode: shared の時に使われる.
2502# -name-default: (noname)
2503
2504# 外部にTiarraさんを使っているときに, そこのネットワークを切り出して表示する.
2505# exteact-network: <netname> <remote-sep>
2506# <netname> ::= このTiarraさんから見たときの外部Tiarraさんのネットワーク名.
2507#               (このtiarra.confで指定しているネットワーク名)
2508# <remote-sep> ::= 外部Tiarraさんで使っているセパレータ.
2509#                  (こっちはこのtiarra.confのではないです)
2510#                  省略すると @ と仮定.
2511-exteact-network: tiarra
2512-exteact-network: tiarra @
2513
2514=end tiarra-doc
2515
2516=cut
Note: See TracBrowser for help on using the browser.