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

Revision 15575, 63.4 kB (checked in by hio, 6 years ago)

WebClient?, 認証情報のログが減っていたので補完.

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