/[irc-logger]/trunk/bin/irc-logger.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/bin/irc-logger.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/irc-logger.pl revision 18 by dpavlin, Mon Mar 13 17:07:40 2006 UTC trunk/bin/irc-logger.pl revision 83 by dpavlin, Fri Feb 29 22:11:07 2008 UTC
# Line 10  irc-logger.pl Line 10  irc-logger.pl
10    
11  ./irc-logger.pl  ./irc-logger.pl
12    
13    =head2 Options
14    
15    =over 4
16    
17    =item --import-dircproxy=filename
18    
19    Import log from C<dircproxy> to C<irc-logger> database
20    
21    =item --log=irc-logger.log
22    
23    Name of log file
24    
25    =back
26    
27  =head1 DESCRIPTION  =head1 DESCRIPTION
28    
29  log all conversation on irc channel  log all conversation on irc channel
# Line 18  log all conversation on irc channel Line 32  log all conversation on irc channel
32    
33  ## CONFIG  ## CONFIG
34    
35  my $NICK = 'irc-logger-dev';  my $HOSTNAME = `hostname -f`;
36    chomp($HOSTNAME);
37    
38    my $NICK = 'irc-logger';
39    $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
40  my $CONNECT =  my $CONNECT =
41    {Server => 'irc.freenode.net',    {Server => 'irc.freenode.net',
42     Nick => $NICK,     Nick => $NICK,
43     Ircname => "try /msg $NICK help",     Ircname => "try /msg $NICK help",
44    };    };
45  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
46    $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
47  my $IRC_ALIAS = "log";  my $IRC_ALIAS = "log";
48    
49  my %FOLLOWS =  my %FOLLOWS =
# Line 33  my %FOLLOWS = Line 52  my %FOLLOWS =
52     ERROR => "/var/log/apache/error.log",     ERROR => "/var/log/apache/error.log",
53    );    );
54    
55  my $DSN = 'DBI:Pg:dbname=irc-logger';  my $DSN = 'DBI:Pg:dbname=' . $NICK;
56    
57  my $ENCODING = 'ISO-8859-2';  my $ENCODING = 'ISO-8859-2';
58    my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
59    
60    my $sleep_on_error = 5;
61    
62    # number of last tags to keep in circular buffer
63    my $last_x_tags = 50;
64    
65    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
66    
67    my $url = "http://$HOSTNAME:$http_port";
68    
69  ## END CONFIG  ## END CONFIG
70    
# Line 44  my $ENCODING = 'ISO-8859-2'; Line 73  my $ENCODING = 'ISO-8859-2';
73  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
74  use HTTP::Status;  use HTTP::Status;
75  use DBI;  use DBI;
76  use Encode qw/from_to/;  use Encode qw/from_to is_utf8/;
77  use Regexp::Common qw /URI/;  use Regexp::Common qw /URI/;
78  use CGI::Simple;  use CGI::Simple;
79    use HTML::TagCloud;
80    use POSIX qw/strftime/;
81    use HTML::CalendarMonthSimple;
82    use Getopt::Long;
83    use DateTime;
84    use URI::Escape;
85    use Data::Dump qw/dump/;
86    use DateTime::Format::ISO8601;
87    use Carp qw/confess/;
88    use XML::Feed;
89    use DateTime::Format::Flexible;
90    
91    my $use_twitter = 1;
92    eval { require Net::Twitter; };
93    $use_twitter = 0 if ($@);
94    
95    my $import_dircproxy;
96    my $log_path;
97    GetOptions(
98            'import-dircproxy:s' => \$import_dircproxy,
99            'log:s' => \$log_path,
100    );
101    
102    $SIG{__DIE__} = sub {
103            confess "fatal error";
104    };
105    
106  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
107    
108    sub _log {
109            print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/;
110    }
111    
112  =for SQL schema  # HTML formatters
113    
114  $dbh->do(qq{  my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
115    my $escape_re  = join '|' => keys %escape;
116    
117    my $tag_regex = '\b([\w-_]+)//';
118    
119    my %nick_enumerator;
120    my $max_color = 0;
121    
122    my $filter = {
123            message => sub {
124                    my $m = shift || return;
125    
126                    # protect HTML from wiki modifications
127                    sub e {
128                            my $t = shift;
129                            return 'uri_unescape{' . uri_escape($t) . '}';
130                    }
131    
132                    $m =~ s/($escape_re)/$escape{$1}/gs;
133                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs ||
134                    $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
135                    $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
136                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
137                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
138    
139                    $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
140                    return $m;
141            },
142            nick => sub {
143                    my $n = shift || return;
144                    if (! $nick_enumerator{$n})  {
145                            my $max = scalar keys %nick_enumerator;
146                            $nick_enumerator{$n} = $max + 1;
147                    }
148                    return '<span class="nick col-' .
149                            ( $nick_enumerator{$n} % $max_color ) .
150                            '">' . $n . '</span>';
151            },
152    };
153    
154    my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
155    
156    my $sql_schema = {
157            log => '
158  create table log (  create table log (
159          id serial,          id serial,
160          time timestamp default now(),          time timestamp default now(),
161          channel text not null,          channel text not null,
162            me boolean default false,
163          nick text not null,          nick text not null,
164          message text not null,          message text not null,
165          primary key(id)          primary key(id)
# Line 66  create table log ( Line 168  create table log (
168  create index log_time on log(time);  create index log_time on log(time);
169  create index log_channel on log(channel);  create index log_channel on log(channel);
170  create index log_nick on log(nick);  create index log_nick on log(nick);
171            ',
172            meta => '
173    create table meta (
174            nick text not null,
175            channel text not null,
176            name text not null,
177            value text,
178            changed timestamp default now(),
179            primary key(nick,channel,name)
180    );
181            ',
182    };
183    
184  });  foreach my $table ( keys %$sql_schema ) {
185    
186            eval {
187                    $dbh->do(qq{ select count(*) from $table });
188            };
189    
190            if ($@) {
191                    warn "creating database table $table in $DSN\n";
192                    $dbh->do( $sql_schema->{ $table } );
193            }
194    }
195    
196    
197    =head2 meta
198    
199    Set or get some meta data into database
200    
201            meta('nick','channel','var_name', $var_value );
202    
203            $var_value = meta('nick','channel','var_name');
204            ( $var_value, $changed ) = meta('nick','channel','var_name');
205    
206  =cut  =cut
207    
208    sub meta {
209            my ($nick,$channel,$name,$value) = @_;
210    
211            # normalize channel name
212            $channel =~ s/^#//;
213    
214            if (defined($value)) {
215    
216                    my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });
217    
218                    eval { $sth->execute( $value, $nick, $channel, $name ) };
219    
220                    # error or no result
221                    if ( $@ || ! $sth->rows ) {
222                            $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
223                            $sth->execute( $value, $nick, $channel, $name );
224                            _log "created $nick/$channel/$name = $value";
225                    } else {
226                            _log "updated $nick/$channel/$name = $value ";
227                    }
228    
229                    return $value;
230    
231            } else {
232    
233                    my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
234                    $sth->execute( $nick, $channel, $name );
235                    my ($v,$c) = $sth->fetchrow_array;
236                    _log "fetched $nick/$channel/$name = $v [$c]";
237                    return ($v,$c) if wantarray;
238                    return $v;
239    
240            }
241    }
242    
243    
244    
245  my $sth = $dbh->prepare(qq{  my $sth = $dbh->prepare(qq{
246  insert into log  insert into log
247          (channel, nick, message)          (channel, me, nick, message, time)
248  values (?,?,?)  values (?,?,?,?,?)
249  });  });
250    
251    
252    my $tags;
253    
254  =head2 get_from_log  =head2 get_from_log
255    
256   my @messages = get_from_log(   my @messages = get_from_log(
# Line 86  values (?,?,?) Line 260  values (?,?,?)
260                  time => '{%s} ',                  time => '{%s} ',
261                  time_channel => '{%s %s} ',                  time_channel => '{%s %s} ',
262                  nick => '%s: ',                  nick => '%s: ',
263                    me_nick => '***%s ',
264                  message => '%s',                  message => '%s',
265          },          },
266          message_filter => sub {          filter => {
267                  # modify message content                  message => sub {
268                  return shift;                          # modify message content
269          }                          return shift;
270                    }
271            },
272            context => 5,
273            full_rows => 1,
274   );   );
275    
276    Order is important. Fields are first passed through C<filter> (if available) and
277    then throgh C<< sprintf($fmt->{message}, $message >> if available.
278    
279    C<context> defines number of messages around each search hit for display.
280    
281    C<full_rows> will return database rows for each result with C<date>, C<time>, C<channel>,
282    C<me>, C<nick> and C<message> keys.
283    
284  =cut  =cut
285    
286  sub get_from_log {  sub get_from_log {
287          my $args = {@_};          my $args = {@_};
288    
289          $args->{limit} ||= 10;          if ( ! $args->{fmt} ) {
290                    $args->{fmt} = {
291          $args->{fmt} ||= {                          date => '[%s] ',
292                  time => '{%s} ',                          time => '{%s} ',
293                  time_channel => '{%s %s} ',                          time_channel => '{%s %s} ',
294                  nick => '%s: ',                          nick => '%s: ',
295                  message => '%s',                          me_nick => '***%s ',
296          };                          message => '%s',
297                    };
298            }
299    
300          my $sql = qq{          my $sql_message = qq{
301                  select                  select
302                          time::date as date,                          time::date as date,
303                          time::time as time,                          time::time as time,
304                          channel,                          channel,
305                            me,
306                          nick,                          nick,
307                          message                          message
308                  from log                  from log
309          };          };
310          $sql .= " where message ilike ? " if ($args->{search});  
311            my $sql_context = qq{
312                    select
313                            id
314                    from log
315            };
316    
317            my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
318    
319            my $sql = $context ? $sql_context : $sql_message;
320    
321            sub check_date {
322                    my $date = shift || return;
323                    my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
324                    if ( $@ ) {
325                            warn "invalid date $date\n";
326                            $new_date = DateTime->now->ymd;
327                    }
328                    return $new_date;
329            }
330    
331            my @where;
332            my @args;
333    
334            if (my $search = $args->{search}) {
335                    $search =~ s/^\s+//;
336                    $search =~ s/\s+$//;
337                    push @where, 'message ilike ? or nick ilike ?';
338                    push @args, ( ( '%' . $search . '%' ) x 2 );
339                    _log "search for '$search'";
340            }
341    
342            if ($args->{tag} && $tags->{ $args->{tag} }) {
343                    push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
344                    _log "search for tags $args->{tag}";
345            }
346    
347            if (my $date = $args->{date} ) {
348                    $date = check_date( $date );
349                    push @where, 'date(time) = ?';
350                    push @args, $date;
351                    _log "search for date $date";
352            }
353    
354            $sql .= " where " . join(" and ", @where) if @where;
355    
356          $sql .= " order by log.time desc";          $sql .= " order by log.time desc";
357          $sql .= " limit " . $args->{limit};          $sql .= " limit " . $args->{limit} if ($args->{limit});
358    
359            #warn "### sql: $sql ", dump( @args );
360    
361          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
362          if ($args->{search}) {          eval { $sth->execute( @args ) };
363                  $sth->execute( '%' . $args->{search} . '%' );          return if $@;
364                  warn "search for '$args->{search}' returned ", $sth->rows, " results\n";  
         } else {  
                 $sth->execute();  
         }  
365          my $last_row = {          my $last_row = {
366                  date => '',                  date => '',
367                  time => '',                  time => '',
# Line 141  sub get_from_log { Line 375  sub get_from_log {
375                  unshift @rows, $row;                  unshift @rows, $row;
376          }          }
377    
378            # normalize nick names
379            map {
380                    $_->{nick} =~ s/^_*(.*?)_*$/$1/
381            } @rows;
382    
383            return @rows if ($args->{full_rows});
384    
385          my @msgs = (          my @msgs = (
386                  "Showing " . ($#rows + 1) . " messages..."                  "Showing " . ($#rows + 1) . " messages..."
387          );          );
388    
389            if ($context) {
390                    my @ids = @rows;
391                    @rows = ();
392    
393                    my $last_to = 0;
394    
395                    my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
396                    foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
397                            my $id = $row_id->{id} || die "can't find id in row";
398            
399                            my ($from, $to) = ($id - $context, $id + $context);
400                            $from = $last_to if ($from < $last_to);
401                            $last_to = $to;
402                            $sth->execute( $from, $to );
403    
404                            #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
405    
406                            while (my $row = $sth->fetchrow_hashref) {
407                                    push @rows, $row;
408                            }
409    
410                    }
411            }
412    
413            # sprintf which can take coderef as first parametar
414            sub cr_sprintf {
415                    my $fmt = shift || return;
416                    if (ref($fmt) eq 'CODE') {
417                            $fmt->(@_);
418                    } else {
419                            sprintf($fmt, @_);
420                    }
421            }
422    
423          foreach my $row (@rows) {          foreach my $row (@rows) {
424    
425                  $row->{time} =~ s#\.\d+##;                  $row->{time} =~ s#\.\d+##;
426    
                 my $t;  
                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                 $t .= $row->{time};  
   
427                  my $msg = '';                  my $msg = '';
428    
429                    $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
430                    my $t = $row->{time};
431    
432                  if ($last_row->{channel} ne $row->{channel}) {                  if ($last_row->{channel} ne $row->{channel}) {
433                          $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});                          $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
434                  } else {                  } else {
435                          $msg .= sprintf($args->{fmt}->{time}, $t);                          $msg .= cr_sprintf($args->{fmt}->{time}, $t);
436                  }                  }
437    
438                  my $append = 1;                  my $append = 1;
439    
440                  if ($last_row->{nick} ne $row->{nick}) {                  my $nick = $row->{nick};
441                          $msg .= sprintf($args->{fmt}->{nick}, $row->{nick});  #               if ($nick =~ s/^_*(.*?)_*$/$1/) {
442    #                       $row->{nick} = $nick;
443    #               }
444    
445                    if ($last_row->{nick} ne $nick) {
446                            # obfu way to find format for me_nick if needed or fallback to default
447                            my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
448                            $fmt ||= '%s';
449    
450                            $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
451    
452                            $msg .= cr_sprintf( $fmt, $nick );
453                          $append = 0;                          $append = 0;
454                  }                  }
455    
456                  if (ref($args->{message_filter}) eq 'CODE') {                  $args->{fmt}->{message} ||= '%s';
457                          $msg .= sprintf($args->{fmt}->{message},                  if (ref($args->{filter}->{message}) eq 'CODE') {
458                                  $args->{message_filter}->(                          $msg .= cr_sprintf($args->{fmt}->{message},
459                                    $args->{filter}->{message}->(
460                                          $row->{message}                                          $row->{message}
461                                  )                                  )
462                          );                          );
463                  } else {                  } else {
464                          $msg .= sprintf($args->{fmt}->{message}, $row->{message});                          $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
465                  }                  }
466    
467                  if ($append && @msgs) {                  if ($append && @msgs) {
# Line 190  sub get_from_log { Line 476  sub get_from_log {
476          return @msgs;          return @msgs;
477  }  }
478    
479    # tags support
480    
481    my $cloud = HTML::TagCloud->new;
482    
483    =head2 add_tag
484    
485     add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
486    
487    =cut
488    
489    my @last_tags;
490    
491    sub add_tag {
492            my $arg = {@_};
493    
494            return unless ($arg->{id} && $arg->{message});
495    
496            my $m = $arg->{message};
497            from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));
498    
499            my @tags;
500    
501            while ($m =~ s#$tag_regex##s) {
502                    my $tag = $1;
503                    next if (! $tag || $tag =~ m/https?:/i);
504                    push @{ $tags->{$tag} }, $arg->{id};
505                    #warn "+tag $tag: $arg->{id}\n";
506                    $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
507                    push @tags, $tag;
508    
509            }
510    
511            if ( @tags ) {
512                    pop @last_tags if $#last_tags == $last_x_tags;
513                    unshift @last_tags, { tags => [ @tags ], %$arg };
514            }
515    
516    }
517    
518    =head2 seed_tags
519    
520    Read all tags from database and create in-memory cache for tags
521    
522    =cut
523    
524    sub seed_tags {
525            my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
526            $sth->execute;
527            while (my $row = $sth->fetchrow_hashref) {
528                    add_tag( %$row );
529            }
530    
531            foreach my $tag (keys %$tags) {
532                    $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
533            }
534    }
535    
536    seed_tags;
537    
538    
539    =head2 save_message
540    
541      save_message(
542            channel => '#foobar',
543            me => 0,
544            nick => 'dpavlin',
545            message => 'test message',
546            time => '2006-06-25 18:57:18',
547      );
548    
549    C<time> is optional, it will use C<< now() >> if it's not available.
550    
551    C<me> if not specified will be C<0> (not C</me> message)
552    
553    =cut
554    
555    sub save_message {
556            my $a = {@_};
557            confess "have msg" if $a->{msg};
558            $a->{me} ||= 0;
559            $a->{time} ||= strftime($TIMESTAMP,localtime());
560    
561            _log
562                    $a->{channel}, " ",
563                    $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
564                    " " . $a->{message};
565    
566            from_to($a->{message}, 'UTF-8', $ENCODING);
567    
568            $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
569            add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
570    }
571    
572    
573    if ($import_dircproxy) {
574            open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
575            warn "importing $import_dircproxy...\n";
576            my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
577            while(<$l>) {
578                    chomp;
579                    if (/^@(\d+)\s(\S+)\s(.+)$/) {
580                            my ($time, $nick, $msg) = ($1,$2,$3);
581    
582                            my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
583    
584                            my $me = 0;
585                            $me = 1 if ($nick =~ m/^\[\S+]/);
586                            $nick =~ s/^[\[<]([^!]+).*$/$1/;
587    
588                            $msg =~ s/^ACTION\s+// if ($me);
589    
590                            save_message(
591                                    channel => $CHANNEL,
592                                    me => $me,
593                                    nick => $nick,
594                                    message => $msg,
595                                    time => $dt->ymd . " " . $dt->hms,
596                            ) if ($nick !~ m/^-/);
597    
598                    } else {
599                            _log "can't parse: $_";
600                    }
601            }
602            close($l);
603            warn "import over\n";
604            exit;
605    }
606    
607    
608    #
609    # POE handing part
610    #
611    
612  my $SKIPPING = 0;               # if skipping, how many we've done  my $SKIPPING = 0;               # if skipping, how many we've done
613  my $SEND_QUEUE;                 # cache  my $SEND_QUEUE;                 # cache
614    my $ping;                                               # ping stats
615    
616  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
617    
618  POE::Session->create  POE::Session->create( inline_states =>
   (inline_states =>  
619     {_start => sub {           {_start => sub {      
620                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
621                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
# Line 215  POE::Session->create Line 633  POE::Session->create
633                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
634                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
635    
636                  from_to($msg, 'UTF-8', $ENCODING);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
637                    meta( $nick, $channel, 'last-msg', $msg );
638        },
639        irc_ctcp_action => sub {
640                    my $kernel = $_[KERNEL];
641                    my $nick = (split /!/, $_[ARG0])[0];
642                    my $channel = $_[ARG1]->[0];
643                    my $msg = $_[ARG2];
644    
645                    save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
646    
647                    if ( $use_twitter ) {
648                            if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
649                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
650                                    _log("sending twitter for $nick/$login on $channel ");
651                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
652                                    $bot->update("<${channel}> $msg");
653                            }
654                    }
655    
                 print "$channel: <$nick> $msg\n";  
                 $sth->execute($channel, $nick, $msg);  
656      },      },
657            irc_ping => sub {
658                    warn "pong ", $_[ARG0], $/;
659                    $ping->{ $_[ARG0] }++;
660            },
661            irc_invite => sub {
662                    my $kernel = $_[KERNEL];
663                    my $nick = (split /!/, $_[ARG0])[0];
664                    my $channel = $_[ARG1];
665    
666                    warn "invited to $channel by $nick";
667    
668                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
669                    $_[KERNEL]->post($IRC_ALIAS => join => $channel);
670    
671            },
672          irc_msg => sub {          irc_msg => sub {
673                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
674                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
675                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
676                    my $channel = $_[ARG1]->[0];
677                  from_to($msg, 'UTF-8', $ENCODING);                  from_to($msg, 'UTF-8', $ENCODING);
678    
679                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
680                  my @out;                  my @out;
681    
682                  print "<< $msg\n";                  _log "<< $msg";
683    
684                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
685    
# Line 237  POE::Session->create Line 687  POE::Session->create
687    
688                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
689    
690                          print ">> /msg $1 $2\n";                          _log ">> /msg $1 $2";
691                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
692                          $res = '';                          $res = '';
693    
# Line 246  POE::Session->create Line 696  POE::Session->create
696                          my $nr = $1 || 10;                          my $nr = $1 || 10;
697    
698                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
699                                  select nick,count(*) from log group by nick order by count desc limit $nr                                  select
700                                            trim(both '_' from nick) as nick,
701                                            count(*) as count,
702                                            sum(length(message)) as len
703                                    from log
704                                    group by trim(both '_' from nick)
705                                    order by len desc,count desc
706                                    limit $nr
707                          });                          });
708                          $sth->execute();                          $sth->execute();
709                          $res = "Top $nr users: ";                          $res = "Top $nr users: ";
710                          my @users;                          my @users;
711                          while (my $row = $sth->fetchrow_hashref) {                          while (my $row = $sth->fetchrow_hashref) {
712                                  push @users,$row->{nick} . ': ' . $row->{count};                                  push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
713                          }                          }
714                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
715                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
716    
717                          foreach my $res (get_from_log( limit => $1 )) {                          my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
718                                  print "last: $res\n";  
719                            foreach my $res (get_from_log( limit => $limit )) {
720                                    _log "last: $res";
721                                  from_to($res, $ENCODING, 'UTF-8');                                  from_to($res, $ENCODING, 'UTF-8');
722                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
723                          }                          }
724    
725                          $res = '';                          $res = '';
726    
727                  } elsif ($msg =~ m/^(search|grep)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
728    
729                          my $what = $2;                          my $what = $2;
730    
731                          foreach my $res (get_from_log( limit => 20, search => $what )) {                          foreach my $res (get_from_log(
732                                  print "search [$what]: $res\n";                                          limit => 20,
733                                            search => $what,
734                                    )) {
735                                    _log "search [$what]: $res";
736                                  from_to($res, $ENCODING, 'UTF-8');                                  from_to($res, $ENCODING, 'UTF-8');
737                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
738                          }                          }
739    
740                          $res = '';                          $res = '';
741    
742                    } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
743    
744                            my ($what,$limit) = ($1,$2);
745                            $limit ||= 100;
746    
747                            my $stat;
748    
749                            foreach my $res (get_from_log(
750                                            limit => $limit,
751                                            search => $what,
752                                            full_rows => 1,
753                                    )) {
754                                    while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
755                                            $stat->{vote}->{$1}++;
756                                            $stat->{from}->{ $res->{nick} }++;
757                                    }
758                            }
759    
760                            my @nicks;
761                            foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
762                                    push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
763                                            "(" . $stat->{from}->{$nick} . ")"
764                                    );
765                            }
766    
767                            $res =
768                                    "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
769                                    " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
770                                    " from " . ( join(", ", @nicks) || 'nobody' );
771    
772                            $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
773    
774                    } elsif ($msg =~ m/^ping/) {
775                            $res = "ping = " . dump( $ping );
776                    } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
777                            if ( ! defined( $1 ) ) {
778                                    my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
779                                    $sth->execute( $nick, $channel );
780                                    $res = "config for $nick on $channel";
781                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
782                                            $res .= " | $n = $v";
783                                    }
784                            } elsif ( ! $2 ) {
785                                    my $val = meta( $nick, $channel, $1 );
786                                    $res = "current $1 = " . ( $val ? $val : 'undefined' );
787                            } else {
788                                    my $validate = {
789                                            'last-size' => qr/^\d+/,
790                                            'twitter' => qr/^\w+\s+\w+/,
791                                    };
792    
793                                    my ( $op, $val ) = ( $1, $2 );
794    
795                                    if ( my $regex = $validate->{$op} ) {
796                                            if ( $val =~ $regex ) {
797                                                    meta( $nick, $channel, $op, $val );
798                                                    $res = "saved $op = $val";
799                                            } else {
800                                                    $res = "config option $op = $val doesn't validate against $regex";
801                                            }
802                                    } else {
803                                            $res = "config option $op doesn't exist";
804                                    }
805                            }
806                  }                  }
807    
808                  if ($res) {                  if ($res) {
809                          print ">> [$nick] $res\n";                          _log ">> [$nick] $res";
810                          from_to($res, $ENCODING, 'UTF-8');                          from_to($res, $ENCODING, 'UTF-8');
811                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
812                  }                  }
813    
814          },          },
815          irc_477 => sub {          irc_477 => sub {
816                  print "# irc_477: ",$_[ARG1], "\n";                  _log "# irc_477: ",$_[ARG1];
817                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
818          },          },
819          irc_505 => sub {          irc_505 => sub {
820                  print "# irc_505: ",$_[ARG1], "\n";                  _log "# irc_505: ",$_[ARG1];
821                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
822  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
823  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
824          },          },
825          irc_registered => sub {          irc_registered => sub {
826                  warn "## indetify $NICK\n";                  _log "## registrated $NICK";
827                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
828          },          },
829            irc_disconnected => sub {
830                    _log "## disconnected, reconnecting again";
831                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
832            },
833            irc_socketerr => sub {
834                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
835                    sleep($sleep_on_error);
836                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
837            },
838  #       irc_433 => sub {  #       irc_433 => sub {
839  #               print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
840  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
841  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
842  #       },  #       },
         irc_372 => sub {  
                 print "MOTD: ", $_[ARG1], "\n";  
         },  
         irc_snotice => sub {  
                 print "(server notice): ", $_[ARG0], "\n";  
         },  
     (map  
      {  
        ;"irc_$_" => sub { }}  
      qw(  
                 )),  
 #       join  
 #       ctcp_version  
 #       connected snotice ctcp_action ping notice mode part quit  
 #       001 002 003 004 005  
 #       250 251 252 253 254 265 266  
 #       332 333 353 366 372 375 376  
 #       477  
843      _child => sub {},      _child => sub {},
844      _default => sub {      _default => sub {
845        printf "%s: session %s caught an unhandled %s event.\n",                  _log sprintf "sID:%s %s %s",
846          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          $_[SESSION]->ID, $_[ARG0],
847        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
848          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
849                            "";
850        0;                        # false for signals        0;                        # false for signals
851      },      },
852      my_add => sub {      my_add => sub {
# Line 397  POE::Session->create Line 915  POE::Session->create
915  # http server  # http server
916    
917  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
918          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
919            PreHandler => {
920                    '/' => sub {
921                            $_[0]->header(Connection => 'close')
922                    }
923            },
924          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
925          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
926  );  );
927    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
928  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
929  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
930  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
931  .nick { color: #0000ff; font-size: 80%; }  .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
932    .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
933  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
934  .search { float: right; }  .search { float: right; }
935    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
936    a:hover.tag { border: 1px solid #eee }
937    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
938    /*
939    .col-0 { background: #ffff66 }
940    .col-1 { background: #a0ffff }
941    .col-2 { background: #99ff99 }
942    .col-3 { background: #ff9999 }
943    .col-4 { background: #ff66ff }
944    */
945    .calendar { border: 1px solid red; width: 100%; }
946    .month { border: 0px; width: 100%; }
947  _END_OF_STYLE_  _END_OF_STYLE_
948    
949    $max_color = 0;
950    
951    my @cols = qw(
952            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
953            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
954            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
955            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
956            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
957    );
958    
959    foreach my $c (@cols) {
960            $style .= ".col-${max_color} { background: $c }\n";
961            $max_color++;
962    }
963    warn "defined $max_color colors for users...\n";
964    
965  sub root_handler {  sub root_handler {
966          my ($request, $response) = @_;          my ($request, $response) = @_;
967          $response->code(RC_OK);          $response->code(RC_OK);
968          $response->content_type("text/html; charset=$ENCODING");  
969            # this doesn't seem to work, so moved to PreHandler
970            #$response->header(Connection => 'close');
971    
972            return RC_OK if $request->uri =~ m/favicon.ico$/;
973    
974          my $q;          my $q;
975    
# Line 430  sub root_handler { Line 983  sub root_handler {
983    
984          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
985    
986          $response->content(          if ($request->url =~ m#/rss(?:/(tags|last-tag)\w*(?:=(\d+))?)?#i) {
987                  qq{<html><head><title>$NICK</title><style type="text/css">$style</style></head><body>                  my $show = lc($1);
988                  <form method="post" class="search">                  my $nr = $2;
989    
990                    my $type = 'RSS';       # Atom
991    
992                    $response->content_type( 'application/' . lc($type) . '+xml' );
993    
994                    my $html = '<!-- error -->';
995                    #warn "create $type feed from ",dump( @last_tags );
996    
997                    my $feed = XML::Feed->new( $type );
998    
999                    if ( $show eq 'tags' ) {
1000                            $nr ||= 50;
1001                            $feed->title( "tags from $CHANNEL" );
1002                            $feed->link( "$url/tags" );
1003                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1004                            my $feed_entry = XML::Feed::Entry->new($type);
1005                            $feed_entry->title( "$nr tags from $CHANNEL" );
1006                            $feed_entry->author( $NICK );
1007                            $feed_entry->link( '/#tags'  );
1008    
1009                            $feed_entry->content(
1010                                    qq{<![CDATA[<style type="text/css">}
1011                                    . $cloud->css
1012                                    . qq{</style>}
1013                                    . $cloud->html( $nr )
1014                                    . qq{]]>}
1015                            );
1016                            $feed->add_entry( $feed_entry );
1017    
1018                    } elsif ( $show eq 'last-tag' ) {
1019    
1020                            $nr ||= $last_x_tags;
1021                            $nr = $last_x_tags if $nr > $last_x_tags;
1022    
1023                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1024                            $feed->link( $url );
1025                            $feed->description( "collects messages which have tags// in them" );
1026    
1027                            foreach my $m ( @last_tags ) {
1028    #                               warn dump( $m );
1029                                    #my $tags = join(' ', @{$m->{tags}} );
1030                                    my $feed_entry = XML::Feed::Entry->new($type);
1031                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1032                                    $feed_entry->author( $m->{nick} );
1033                                    $feed_entry->link( '/#' . $m->{id}  );
1034                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1035    
1036                                    my $message = $filter->{message}->( $m->{message} );
1037                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1038    #                               warn "## message = $message\n";
1039                                    from_to( $message, $ENCODING, 'UTF-8' );
1040    
1041                                    #$feed_entry->summary(
1042                                    $feed_entry->content(
1043                                            "<![CDATA[$message]]>"
1044                                    );
1045                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1046                                    $feed->add_entry( $feed_entry );
1047    
1048                                    $nr--;
1049                                    last if $nr <= 0;
1050    
1051                            }
1052    
1053                    } else {
1054                            warn "!! unknown rss request for $show\n";
1055                            return RC_DENY;
1056                    }
1057    
1058                    $response->content( $feed->as_xml );
1059                    return RC_OK;
1060            }
1061    
1062            if ( $@ ) {
1063                    warn "$@";
1064            }
1065    
1066            $response->content_type("text/html; charset=$ENCODING");
1067    
1068            my $html =
1069                    qq{<html><head><title>$NICK</title><style type="text/css">$style}
1070                    . $cloud->css
1071                    . qq{</style></head><body>}
1072                    . qq{
1073                    <form method="post" class="search" action="/">
1074                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1075                  <input type="submit" value="search">                  <input type="submit" value="search">
1076                  </form>                  </form>
1077                  <p>                  }
1078                  } .                  . $cloud->html(500)
1079                  join("</p><p>",                  . qq{<p>};
1080    
1081            if ($request->url =~ m#/tags?#) {
1082                    # nop
1083            } elsif ($request->url =~ m#/history#) {
1084                    my $sth = $dbh->prepare(qq{
1085                            select date(time) as date,count(*) as nr,sum(length(message)) as len
1086                                    from log
1087                                    group by date(time)
1088                                    order by date(time) desc
1089                    });
1090                    $sth->execute();
1091                    my ($l_yyyy,$l_mm) = (0,0);
1092                    $html .= qq{<table class="calendar"><tr>};
1093                    my $cal;
1094                    my $ord = 0;
1095                    while (my $row = $sth->fetchrow_hashref) {
1096                            # this is probably PostgreSQL specific, expects ISO date
1097                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1098                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
1099                                    if ( $cal ) {
1100                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1101                                            $ord++;
1102                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1103                                    }
1104                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1105                                    $cal->border(1);
1106                                    $cal->width('30%');
1107                                    $cal->cellheight('5em');
1108                                    $cal->tableclass('month');
1109                                    #$cal->cellclass('day');
1110                                    $cal->sunday('SUN');
1111                                    $cal->saturday('SAT');
1112                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1113                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
1114                            }
1115                            $cal->setcontent($dd, qq[
1116                                    <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1117                            ]);
1118                            
1119                    }
1120                    $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1121    
1122            } else {
1123                    $html .= join("</p><p>",
1124                          get_from_log(                          get_from_log(
1125                                  limit => $q->param('limit') || 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1126                                  search => $q->param('search') || $q->param('grep') || undef,                                  search => $search || undef,
1127                                    tag => $q->param('tag') || undef,
1128                                    date => $q->param('date') || undef,
1129                                  fmt => {                                  fmt => {
1130                                            date => sub {
1131                                                    my $date = shift || return;
1132                                                    qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1133                                            },
1134                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1135                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
1136                                          nick => '<span class="nick">%s:</span> ',                                          nick => '%s:&nbsp;',
1137                                            me_nick => '***%s&nbsp;',
1138                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1139                                  },                                  },
1140                                  message_filter => sub {                                  filter => $filter,
                                         my $m = shift || return;  
                                         $m =~ s/($escape_re)/$escape{$1}/gs;  
                                         $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;  
                                         return $m;  
                                 },  
1141                          )                          )
1142                  ) .                  );
1143                  qq{</p></body></html>}          }
1144          );  
1145            $html .= qq{</p>
1146            <hr/>
1147            <p>See <a href="/history">history</a> of all messages.</p>
1148            </body></html>};
1149    
1150            $response->content( $html );
1151            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1152          return RC_OK;          return RC_OK;
1153  }  }
1154    
Legend:
Removed from v.18  
changed lines
  Added in v.83
  ViewVC Help
Powered by ViewVC 1.1.26