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