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

Revision 15519, 62.5 kB (checked in by hio, 5 years ago)

WebClient?, method="post" は対応できなかったりするぽい.

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