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