/[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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 126 - (hide annotations)
Fri Mar 14 16:06:57 2008 UTC (16 years ago) by dpavlin
File MIME type: text/plain
File size: 36289 byte(s)
remove on-disk queue (since we can't really fork anyway) so
messages and send out instantly which also help in response time
1 dpavlin 4 #!/usr/bin/perl -w
2     use strict;
3     $|++;
4    
5 dpavlin 122 use POE qw(Component::IRC Component::Server::HTTP Component::Client::HTTP);
6 dpavlin 102 use HTTP::Status;
7     use DBI;
8     use Regexp::Common qw /URI/;
9     use CGI::Simple;
10     use HTML::TagCloud;
11     use POSIX qw/strftime/;
12     use HTML::CalendarMonthSimple;
13     use Getopt::Long;
14     use DateTime;
15     use URI::Escape;
16     use Data::Dump qw/dump/;
17     use DateTime::Format::ISO8601;
18     use Carp qw/confess/;
19     use XML::Feed;
20     use DateTime::Format::Flexible;
21 dpavlin 123 use Encode;
22 dpavlin 102
23 dpavlin 5 =head1 NAME
24    
25     irc-logger.pl
26    
27     =head1 SYNOPSIS
28    
29     ./irc-logger.pl
30    
31 dpavlin 37 =head2 Options
32    
33     =over 4
34    
35     =item --import-dircproxy=filename
36    
37     Import log from C<dircproxy> to C<irc-logger> database
38    
39 dpavlin 45 =item --log=irc-logger.log
40    
41     =back
42    
43 dpavlin 5 =head1 DESCRIPTION
44    
45     log all conversation on irc channel
46    
47     =cut
48    
49 dpavlin 4 ## CONFIG
50    
51 dpavlin 119 my $debug = 0;
52    
53 dpavlin 109 my $irc_config = {
54     nick => 'irc-logger',
55     server => 'irc.freenode.net',
56     port => 6667,
57     ircname => 'Anna the bot: try /msg irc-logger help',
58     };
59    
60 dpavlin 73 my $HOSTNAME = `hostname -f`;
61     chomp($HOSTNAME);
62 dpavlin 33
63 dpavlin 109
64 dpavlin 4 my $CHANNEL = '#razmjenavjestina';
65    
66 dpavlin 109 if ( $HOSTNAME =~ m/llin/ ) {
67 dpavlin 114 $irc_config->{nick} = 'irc-logger-llin';
68 dpavlin 109 # $irc_config = {
69 dpavlin 114 # nick => 'irc-logger-llin',
70 dpavlin 109 # server => 'localhost',
71     # port => 6668,
72     # };
73     $CHANNEL = '#irc-logger';
74     } elsif ( $HOSTNAME =~ m/lugarin/ ) {
75     $irc_config->{server} = 'irc.carnet.hr';
76 dpavlin 102 $CHANNEL = '#riss';
77     }
78    
79 dpavlin 109 my @channels = ( $CHANNEL );
80 dpavlin 102
81 dpavlin 122 warn "## config = ", dump( $irc_config ) if $debug;
82 dpavlin 109
83     my $NICK = $irc_config->{nick} or die "no nick?";
84    
85 dpavlin 19 my $DSN = 'DBI:Pg:dbname=' . $NICK;
86 dpavlin 5
87 dpavlin 34 my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
88 dpavlin 14
89 dpavlin 41 my $sleep_on_error = 5;
90    
91 dpavlin 79 # number of last tags to keep in circular buffer
92     my $last_x_tags = 50;
93    
94 dpavlin 85 # don't pull rss feeds more often than this
95     my $rss_min_delay = 60;
96    
97 dpavlin 70 my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
98    
99 dpavlin 73 my $url = "http://$HOSTNAME:$http_port";
100    
101 dpavlin 4 ## END CONFIG
102    
103 dpavlin 54 my $use_twitter = 1;
104     eval { require Net::Twitter; };
105     $use_twitter = 0 if ($@);
106    
107 dpavlin 37 my $import_dircproxy;
108 dpavlin 45 my $log_path;
109 dpavlin 37 GetOptions(
110     'import-dircproxy:s' => \$import_dircproxy,
111 dpavlin 45 'log:s' => \$log_path,
112 dpavlin 122 'debug!' => \$debug,
113 dpavlin 37 );
114    
115 dpavlin 87 #$SIG{__DIE__} = sub {
116     # confess "fatal error";
117     #};
118 dpavlin 68
119 dpavlin 45 sub _log {
120 dpavlin 116 print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
121 dpavlin 45 }
122    
123 dpavlin 116 open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n";
124    
125 dpavlin 119
126 dpavlin 70 # HTML formatters
127    
128     my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
129     my $escape_re = join '|' => keys %escape;
130    
131     my $tag_regex = '\b([\w-_]+)//';
132    
133     my %nick_enumerator;
134     my $max_color = 0;
135    
136     my $filter = {
137     message => sub {
138     my $m = shift || return;
139    
140     # protect HTML from wiki modifications
141     sub e {
142     my $t = shift;
143 dpavlin 98 return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}';
144 dpavlin 70 }
145    
146     $m =~ s/($escape_re)/$escape{$1}/gs;
147 dpavlin 98 $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;
148 dpavlin 70 $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
149 dpavlin 73 $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
150 dpavlin 70 $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
151     $m =~ s#_(\w+)_#<u>$1</u>#gs;
152    
153     $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
154     return $m;
155     },
156     nick => sub {
157     my $n = shift || return;
158     if (! $nick_enumerator{$n}) {
159     my $max = scalar keys %nick_enumerator;
160     $nick_enumerator{$n} = $max + 1;
161     }
162     return '<span class="nick col-' .
163     ( $nick_enumerator{$n} % $max_color ) .
164     '">' . $n . '</span>';
165     },
166     };
167    
168 dpavlin 112 # POE IRC
169     my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
170     die "can't start ", dump( $irc_config ), ": $!";
171    
172     my $irc = $poe_irc->session_id();
173     _log "IRC session_id $irc";
174    
175 dpavlin 5 my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
176 dpavlin 88 $dbh->do( qq{ set client_encoding = 'UTF-8' } );
177 dpavlin 5
178 dpavlin 50 my $sql_schema = {
179 dpavlin 85 log => qq{
180 dpavlin 5 create table log (
181     id serial,
182     time timestamp default now(),
183     channel text not null,
184 dpavlin 19 me boolean default false,
185 dpavlin 5 nick text not null,
186     message text not null,
187     primary key(id)
188     );
189    
190     create index log_time on log(time);
191     create index log_channel on log(channel);
192     create index log_nick on log(nick);
193 dpavlin 85 },
194     meta => q{
195 dpavlin 50 create table meta (
196     nick text not null,
197     channel text not null,
198     name text not null,
199     value text,
200 dpavlin 85 changed timestamp default 'now()',
201 dpavlin 50 primary key(nick,channel,name)
202     );
203 dpavlin 85 },
204     feeds => qq{
205     create table feeds (
206     id serial,
207     url text not null,
208     name text,
209 dpavlin 86 delay interval not null default '5 min',
210 dpavlin 85 active boolean default true,
211 dpavlin 97 channel text not null,
212     nick text not null,
213     private boolean default false,
214 dpavlin 85 last_update timestamp default 'now()',
215     polls int default 0,
216     updates int default 0
217     );
218     create unique index feeds_url on feeds(url);
219 dpavlin 97 insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
220 dpavlin 85 },
221 dpavlin 50 };
222 dpavlin 5
223 dpavlin 50 foreach my $table ( keys %$sql_schema ) {
224    
225     eval {
226     $dbh->do(qq{ select count(*) from $table });
227     };
228    
229     if ($@) {
230     warn "creating database table $table in $DSN\n";
231     $dbh->do( $sql_schema->{ $table } );
232     }
233 dpavlin 19 }
234 dpavlin 5
235 dpavlin 50
236     =head2 meta
237    
238     Set or get some meta data into database
239    
240     meta('nick','channel','var_name', $var_value );
241    
242     $var_value = meta('nick','channel','var_name');
243     ( $var_value, $changed ) = meta('nick','channel','var_name');
244    
245     =cut
246    
247     sub meta {
248     my ($nick,$channel,$name,$value) = @_;
249    
250     # normalize channel name
251     $channel =~ s/^#//;
252    
253     if (defined($value)) {
254    
255     my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });
256    
257     eval { $sth->execute( $value, $nick, $channel, $name ) };
258    
259     # error or no result
260     if ( $@ || ! $sth->rows ) {
261     $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
262     $sth->execute( $value, $nick, $channel, $name );
263 dpavlin 95 warn "## created $nick/$channel/$name = $value\n";
264 dpavlin 50 } else {
265 dpavlin 95 warn "## updated $nick/$channel/$name = $value\n";
266 dpavlin 50 }
267    
268     return $value;
269    
270     } else {
271    
272     my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
273     $sth->execute( $nick, $channel, $name );
274     my ($v,$c) = $sth->fetchrow_array;
275 dpavlin 95 warn "## fetched $nick/$channel/$name = $v [$c]\n";
276 dpavlin 50 return ($v,$c) if wantarray;
277     return $v;
278    
279     }
280     }
281    
282    
283    
284 dpavlin 87 my $sth_insert_log = $dbh->prepare(qq{
285 dpavlin 5 insert into log
286 dpavlin 37 (channel, me, nick, message, time)
287     values (?,?,?,?,?)
288 dpavlin 5 });
289    
290 dpavlin 50
291 dpavlin 28 my $tags;
292    
293 dpavlin 11 =head2 get_from_log
294 dpavlin 5
295 dpavlin 11 my @messages = get_from_log(
296     limit => 42,
297     search => '%what to stuff in ilike%',
298 dpavlin 13 fmt => {
299     time => '{%s} ',
300     time_channel => '{%s %s} ',
301     nick => '%s: ',
302 dpavlin 20 me_nick => '***%s ',
303 dpavlin 13 message => '%s',
304     },
305 dpavlin 20 filter => {
306     message => sub {
307     # modify message content
308     return shift;
309     }
310 dpavlin 21 },
311     context => 5,
312 dpavlin 42 full_rows => 1,
313 dpavlin 11 );
314    
315 dpavlin 20 Order is important. Fields are first passed through C<filter> (if available) and
316     then throgh C<< sprintf($fmt->{message}, $message >> if available.
317    
318 dpavlin 21 C<context> defines number of messages around each search hit for display.
319    
320 dpavlin 42 C<full_rows> will return database rows for each result with C<date>, C<time>, C<channel>,
321     C<me>, C<nick> and C<message> keys.
322    
323 dpavlin 11 =cut
324    
325     sub get_from_log {
326     my $args = {@_};
327    
328 dpavlin 68 if ( ! $args->{fmt} ) {
329     $args->{fmt} = {
330     date => '[%s] ',
331     time => '{%s} ',
332     time_channel => '{%s %s} ',
333     nick => '%s: ',
334     me_nick => '***%s ',
335     message => '%s',
336     };
337     }
338 dpavlin 13
339 dpavlin 21 my $sql_message = qq{
340 dpavlin 11 select
341     time::date as date,
342     time::time as time,
343     channel,
344 dpavlin 20 me,
345 dpavlin 11 nick,
346     message
347     from log
348     };
349 dpavlin 21
350     my $sql_context = qq{
351     select
352     id
353     from log
354     };
355    
356     my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
357    
358     my $sql = $context ? $sql_context : $sql_message;
359    
360 dpavlin 67 sub check_date {
361 dpavlin 68 my $date = shift || return;
362     my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
363 dpavlin 64 if ( $@ ) {
364 dpavlin 68 warn "invalid date $date\n";
365     $new_date = DateTime->now->ymd;
366 dpavlin 64 }
367 dpavlin 68 return $new_date;
368 dpavlin 67 }
369    
370 dpavlin 68 my @where;
371     my @args;
372 dpavlin 100 my $msg;
373 dpavlin 68
374     if (my $search = $args->{search}) {
375     $search =~ s/^\s+//;
376     $search =~ s/\s+$//;
377     push @where, 'message ilike ? or nick ilike ?';
378     push @args, ( ( '%' . $search . '%' ) x 2 );
379 dpavlin 100 $msg = "Search for '$search'";
380 dpavlin 63 }
381 dpavlin 68
382     if ($args->{tag} && $tags->{ $args->{tag} }) {
383     push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
384 dpavlin 100 $msg = "Search for tags $args->{tag}";
385 dpavlin 68 }
386    
387     if (my $date = $args->{date} ) {
388     $date = check_date( $date );
389     push @where, 'date(time) = ?';
390     push @args, $date;
391 dpavlin 100 $msg = "search for date $date";
392 dpavlin 68 }
393    
394     $sql .= " where " . join(" and ", @where) if @where;
395    
396 dpavlin 11 $sql .= " order by log.time desc";
397 dpavlin 35 $sql .= " limit " . $args->{limit} if ($args->{limit});
398 dpavlin 11
399 dpavlin 68 #warn "### sql: $sql ", dump( @args );
400    
401 dpavlin 11 my $sth = $dbh->prepare( $sql );
402 dpavlin 69 eval { $sth->execute( @args ) };
403     return if $@;
404 dpavlin 68
405 dpavlin 100 my $nr_results = $sth->rows;
406    
407 dpavlin 11 my $last_row = {
408     date => '',
409     time => '',
410     channel => '',
411     nick => '',
412     };
413    
414     my @rows;
415    
416     while (my $row = $sth->fetchrow_hashref) {
417     unshift @rows, $row;
418     }
419    
420 dpavlin 42 # normalize nick names
421     map {
422     $_->{nick} =~ s/^_*(.*?)_*$/$1/
423     } @rows;
424    
425     return @rows if ($args->{full_rows});
426    
427 dpavlin 100 $msg .= ' produced ' . (
428     $nr_results == 0 ? 'no results' :
429     $nr_results == 0 ? 'one result' :
430     $nr_results . ' results'
431 dpavlin 16 );
432 dpavlin 11
433 dpavlin 100 my @msgs = ( $msg );
434    
435 dpavlin 21 if ($context) {
436     my @ids = @rows;
437     @rows = ();
438    
439     my $last_to = 0;
440    
441     my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
442     foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
443     my $id = $row_id->{id} || die "can't find id in row";
444    
445     my ($from, $to) = ($id - $context, $id + $context);
446     $from = $last_to if ($from < $last_to);
447     $last_to = $to;
448     $sth->execute( $from, $to );
449    
450     #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
451    
452     while (my $row = $sth->fetchrow_hashref) {
453     push @rows, $row;
454     }
455    
456     }
457     }
458    
459 dpavlin 35 # sprintf which can take coderef as first parametar
460     sub cr_sprintf {
461     my $fmt = shift || return;
462     if (ref($fmt) eq 'CODE') {
463     $fmt->(@_);
464     } else {
465     sprintf($fmt, @_);
466     }
467     }
468    
469 dpavlin 11 foreach my $row (@rows) {
470    
471     $row->{time} =~ s#\.\d+##;
472    
473     my $msg = '';
474    
475 dpavlin 35 $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
476 dpavlin 26 my $t = $row->{time};
477    
478 dpavlin 13 if ($last_row->{channel} ne $row->{channel}) {
479 dpavlin 35 $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
480 dpavlin 13 } else {
481 dpavlin 35 $msg .= cr_sprintf($args->{fmt}->{time}, $t);
482 dpavlin 13 }
483 dpavlin 11
484 dpavlin 12 my $append = 1;
485 dpavlin 11
486 dpavlin 22 my $nick = $row->{nick};
487 dpavlin 42 # if ($nick =~ s/^_*(.*?)_*$/$1/) {
488     # $row->{nick} = $nick;
489     # }
490 dpavlin 24
491 dpavlin 105 $append = 0 if $row->{me};
492    
493 dpavlin 22 if ($last_row->{nick} ne $nick) {
494 dpavlin 20 # obfu way to find format for me_nick if needed or fallback to default
495     my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
496     $fmt ||= '%s';
497    
498     $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
499    
500 dpavlin 35 $msg .= cr_sprintf( $fmt, $nick );
501 dpavlin 12 $append = 0;
502     }
503    
504 dpavlin 20 $args->{fmt}->{message} ||= '%s';
505     if (ref($args->{filter}->{message}) eq 'CODE') {
506 dpavlin 35 $msg .= cr_sprintf($args->{fmt}->{message},
507 dpavlin 20 $args->{filter}->{message}->(
508 dpavlin 15 $row->{message}
509     )
510     );
511     } else {
512 dpavlin 35 $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
513 dpavlin 15 }
514 dpavlin 11
515 dpavlin 12 if ($append && @msgs) {
516     $msgs[$#msgs] .= " " . $msg;
517     } else {
518     push @msgs, $msg;
519     }
520 dpavlin 11
521     $last_row = $row;
522     }
523    
524     return @msgs;
525     }
526    
527 dpavlin 37 # tags support
528 dpavlin 11
529 dpavlin 37 my $cloud = HTML::TagCloud->new;
530 dpavlin 4
531 dpavlin 37 =head2 add_tag
532 dpavlin 4
533 dpavlin 70 add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
534 dpavlin 37
535     =cut
536    
537 dpavlin 70 my @last_tags;
538    
539 dpavlin 37 sub add_tag {
540     my $arg = {@_};
541    
542     return unless ($arg->{id} && $arg->{message});
543    
544     my $m = $arg->{message};
545    
546 dpavlin 70 my @tags;
547    
548 dpavlin 37 while ($m =~ s#$tag_regex##s) {
549     my $tag = $1;
550     next if (! $tag || $tag =~ m/https?:/i);
551     push @{ $tags->{$tag} }, $arg->{id};
552     #warn "+tag $tag: $arg->{id}\n";
553 dpavlin 73 $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
554 dpavlin 70 push @tags, $tag;
555    
556 dpavlin 37 }
557 dpavlin 70
558     if ( @tags ) {
559 dpavlin 74 pop @last_tags if $#last_tags == $last_x_tags;
560     unshift @last_tags, { tags => [ @tags ], %$arg };
561 dpavlin 70 }
562    
563 dpavlin 37 }
564    
565     =head2 seed_tags
566    
567     Read all tags from database and create in-memory cache for tags
568    
569     =cut
570    
571     sub seed_tags {
572 dpavlin 74 my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
573 dpavlin 37 $sth->execute;
574     while (my $row = $sth->fetchrow_hashref) {
575     add_tag( %$row );
576     }
577    
578     foreach my $tag (keys %$tags) {
579 dpavlin 73 $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
580 dpavlin 37 }
581     }
582    
583     seed_tags;
584    
585    
586 dpavlin 36 =head2 save_message
587    
588 dpavlin 37 save_message(
589     channel => '#foobar',
590     me => 0,
591     nick => 'dpavlin',
592 dpavlin 70 message => 'test message',
593 dpavlin 37 time => '2006-06-25 18:57:18',
594     );
595 dpavlin 36
596 dpavlin 37 C<time> is optional, it will use C<< now() >> if it's not available.
597    
598     C<me> if not specified will be C<0> (not C</me> message)
599    
600 dpavlin 36 =cut
601    
602     sub save_message {
603 dpavlin 37 my $a = {@_};
604 dpavlin 70 confess "have msg" if $a->{msg};
605 dpavlin 37 $a->{me} ||= 0;
606 dpavlin 38 $a->{time} ||= strftime($TIMESTAMP,localtime());
607 dpavlin 37
608 dpavlin 125 _log "ARCHIVE",
609 dpavlin 37 $a->{channel}, " ",
610     $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
611 dpavlin 70 " " . $a->{message};
612 dpavlin 37
613 dpavlin 87 $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
614 dpavlin 70 add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
615 dpavlin 36 }
616    
617 dpavlin 50
618 dpavlin 37 if ($import_dircproxy) {
619     open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
620     warn "importing $import_dircproxy...\n";
621 dpavlin 69 my $tz_offset = 1 * 60 * 60; # TZ GMT+2
622 dpavlin 37 while(<$l>) {
623     chomp;
624     if (/^@(\d+)\s(\S+)\s(.+)$/) {
625     my ($time, $nick, $msg) = ($1,$2,$3);
626    
627     my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
628    
629     my $me = 0;
630     $me = 1 if ($nick =~ m/^\[\S+]/);
631     $nick =~ s/^[\[<]([^!]+).*$/$1/;
632    
633     $msg =~ s/^ACTION\s+// if ($me);
634    
635     save_message(
636     channel => $CHANNEL,
637     me => $me,
638     nick => $nick,
639 dpavlin 70 message => $msg,
640 dpavlin 37 time => $dt->ymd . " " . $dt->hms,
641     ) if ($nick !~ m/^-/);
642    
643     } else {
644 dpavlin 45 _log "can't parse: $_";
645 dpavlin 37 }
646     }
647     close($l);
648     warn "import over\n";
649     exit;
650     }
651    
652 dpavlin 85 #
653     # RSS follow
654     #
655 dpavlin 37
656 dpavlin 108 my $_stat;
657 dpavlin 85
658 dpavlin 122 POE::Component::Client::HTTP->spawn(
659     Alias => 'rss-fetch',
660     Timeout => 30,
661     );
662 dpavlin 85
663 dpavlin 125 =head2 rss_parse_xml
664    
665     rss_parse_xml({
666     url => 'http://www.example.com/rss',
667     send_rss_msgs => 42,
668     });
669    
670     =cut
671    
672 dpavlin 122 sub rss_parse_xml {
673 dpavlin 126 my ($kernel,$args) = @_;
674 dpavlin 85
675 dpavlin 122 warn "## rss_parse_xml ",dump( @_ ) if $debug;
676    
677 dpavlin 85 # how many messages to send out when feed is seen for the first time?
678 dpavlin 125 my $send_rss_msgs = $args->{send_rss_msgs};
679     $send_rss_msgs = 1 if ! defined $send_rss_msgs;
680 dpavlin 85
681 dpavlin 126 warn "## RSS fetch first $send_rss_msgs items from", $args->{url} if $debug;
682 dpavlin 87
683 dpavlin 122 my $feed = XML::Feed->parse( \$args->{xml} );
684 dpavlin 85 if ( ! $feed ) {
685 dpavlin 122 _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
686 dpavlin 85 return;
687     }
688 dpavlin 92
689 dpavlin 117 $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
690    
691 dpavlin 87 my ( $total, $updates ) = ( 0, 0 );
692 dpavlin 85 for my $entry ($feed->entries) {
693 dpavlin 87 $total++;
694 dpavlin 85
695 dpavlin 120 my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
696 dpavlin 85 # seen allready?
697 dpavlin 122 warn "## $seen_times ",$entry->id if $debug;
698 dpavlin 120 next if $seen_times > 0;
699 dpavlin 85
700     sub prefix {
701     my ($txt,$var) = @_;
702 dpavlin 93 $var =~ s/\s+/ /gs;
703 dpavlin 85 $var =~ s/^\s+//g;
704 dpavlin 93 $var =~ s/\s+$//g;
705 dpavlin 85 return $txt . $var if $var;
706     }
707    
708 dpavlin 94 # fix absolute and relative links to feed entries
709     my $link = $entry->link;
710     if ( $link =~ m!^/! ) {
711     my $host = $args->{url};
712     $host =~ s!^(http://[^/]+).*$!$1!; #!vim
713     $link = "$host/$link";
714     } elsif ( $link !~ m!^http! ) {
715     $link = $args->{url} . $link;
716     }
717    
718 dpavlin 85 my $msg;
719 dpavlin 90 $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
720 dpavlin 85 $msg .= prefix( ' by ' , $entry->author );
721 dpavlin 92 $msg .= prefix( ' | ' , $entry->title );
722 dpavlin 94 $msg .= prefix( ' | ' , $link );
723 dpavlin 85 # $msg .= prefix( ' id ' , $entry->id );
724 dpavlin 114 if ( my $tags = $entry->category ) {
725     $tags =~ s!^\s+!!;
726     $tags =~ s!\s*$! !;
727 dpavlin 118 $tags =~ s!,?\s+!// !g;
728 dpavlin 114 $msg .= prefix( ' ' , $tags );
729     }
730 dpavlin 85
731 dpavlin 120 if ( $seen_times == 0 && $send_rss_msgs ) {
732 dpavlin 85 $send_rss_msgs--;
733 dpavlin 106 if ( ! $args->{private} ) {
734     # FIXME bug! should be save_message
735 dpavlin 119 save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
736     # $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
737 dpavlin 106 }
738 dpavlin 97 my ( $type, $to ) = ( 'notice', $args->{channel} );
739     ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
740 dpavlin 119
741 dpavlin 126 _log(">> RSS $type to $to:", $msg);
742     $kernel->post( $irc => $type => $to => $msg );
743 dpavlin 119
744 dpavlin 85 $updates++;
745     }
746     }
747    
748     my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
749     $sql .= qq{, updates = updates + $updates } if $updates;
750     $sql .= qq{where id = } . $args->{id};
751 dpavlin 86 eval { $dbh->do( $sql ) };
752 dpavlin 85
753 dpavlin 126 _log "RSS $updates/$total new items from", $args->{url};
754 dpavlin 87
755 dpavlin 85 return $updates;
756     }
757    
758     sub rss_fetch_all {
759 dpavlin 125 my ( $kernel, $send_rss_msgs ) = @_;
760     warn "## rss_fetch_all -- send_rss_msgs: $send_rss_msgs\n" if $debug;
761 dpavlin 85 my $sql = qq{
762 dpavlin 97 select id, url, name, channel, nick, private
763 dpavlin 85 from feeds
764     where active is true
765     };
766     # limit to newer feeds only if we are not sending messages out
767 dpavlin 122 $sql .= qq{ and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
768 dpavlin 85 my $sth = $dbh->prepare( $sql );
769     $sth->execute();
770     warn "# ",$sth->rows," active RSS feeds\n";
771     my $count = 0;
772     while (my $row = $sth->fetchrow_hashref) {
773 dpavlin 125 $row->{send_rss_msgs} = $send_rss_msgs if defined $send_rss_msgs;
774 dpavlin 122 $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
775     $kernel->post(
776     'rss-fetch',
777     'request',
778     'rss_response',
779     HTTP::Request->new( GET => $row->{url} ),
780     );
781 dpavlin 125 warn "## queued rss-fetch ", dump( $row ) if $debug;
782 dpavlin 85 }
783 dpavlin 122 return "OK, scheduled " . $sth->rows . " feeds for refresh";
784 dpavlin 85 }
785    
786    
787     sub rss_check_updates {
788     my $kernel = shift;
789 dpavlin 108 $_stat->{rss}->{last_poll} ||= time();
790     my $dt = time() - $_stat->{rss}->{last_poll};
791 dpavlin 95 if ( $dt > $rss_min_delay ) {
792 dpavlin 119 warn "## rss_check_updates $dt > $rss_min_delay\n";
793 dpavlin 108 $_stat->{rss}->{last_poll} = time();
794 dpavlin 85 _log rss_fetch_all( $kernel );
795     }
796     }
797    
798     POE::Session->create( inline_states => {
799     _start => sub {
800 dpavlin 109 $_[KERNEL]->post( $irc => register => 'all' );
801     $_[KERNEL]->post( $irc => connect => {} );
802 dpavlin 4 },
803 dpavlin 109 irc_001 => sub {
804     my ($kernel,$sender) = @_[KERNEL,SENDER];
805     my $poco_object = $sender->get_heap();
806     _log "connected to",$poco_object->server_name();
807     $kernel->post( $sender => join => $_ ) for @channels;
808 dpavlin 125 # seen RSS cache, so don't send out messages
809     _log rss_fetch_all( $kernel, 0 );
810 dpavlin 109 undef;
811     },
812 dpavlin 122 # irc_255 => sub { # server is done blabbing
813     # $_[KERNEL]->post( $irc => join => $CHANNEL);
814     # },
815 dpavlin 4 irc_public => sub {
816 dpavlin 7 my $kernel = $_[KERNEL];
817     my $nick = (split /!/, $_[ARG0])[0];
818     my $channel = $_[ARG1]->[0];
819     my $msg = $_[ARG2];
820 dpavlin 4
821 dpavlin 70 save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
822 dpavlin 50 meta( $nick, $channel, 'last-msg', $msg );
823 dpavlin 95 rss_check_updates( $kernel );
824 dpavlin 4 },
825 dpavlin 19 irc_ctcp_action => sub {
826     my $kernel = $_[KERNEL];
827     my $nick = (split /!/, $_[ARG0])[0];
828     my $channel = $_[ARG1]->[0];
829     my $msg = $_[ARG2];
830    
831 dpavlin 70 save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
832 dpavlin 50
833 dpavlin 54 if ( $use_twitter ) {
834 dpavlin 58 if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
835 dpavlin 54 my ($login,$passwd) = split(/\s+/,$twitter,2);
836     _log("sending twitter for $nick/$login on $channel ");
837     my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
838     $bot->update("<${channel}> $msg");
839     }
840 dpavlin 50 }
841    
842 dpavlin 19 },
843 dpavlin 43 irc_ping => sub {
844 dpavlin 84 _log( "pong ", $_[ARG0] );
845 dpavlin 109 $_stat->{ping}->{ $_[ARG0] }++;
846 dpavlin 85 rss_check_updates( $_[KERNEL] );
847 dpavlin 43 },
848     irc_invite => sub {
849     my $kernel = $_[KERNEL];
850     my $nick = (split /!/, $_[ARG0])[0];
851     my $channel = $_[ARG1];
852    
853 dpavlin 85 _log "invited to $channel by $nick";
854 dpavlin 43
855 dpavlin 109 $_[KERNEL]->post( $irc => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
856     $_[KERNEL]->post( $irc => 'join' => $channel );
857 dpavlin 43
858     },
859 dpavlin 7 irc_msg => sub {
860     my $kernel = $_[KERNEL];
861     my $nick = (split /!/, $_[ARG0])[0];
862     my $msg = $_[ARG2];
863 dpavlin 50 my $channel = $_[ARG1]->[0];
864 dpavlin 119 warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
865 dpavlin 7
866 dpavlin 8 my $res = "unknown command '$msg', try /msg $NICK help!";
867 dpavlin 11 my @out;
868 dpavlin 7
869 dpavlin 45 _log "<< $msg";
870 dpavlin 7
871 dpavlin 8 if ($msg =~ m/^help/i) {
872 dpavlin 7
873 dpavlin 11 $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
874 dpavlin 8
875 dpavlin 111 } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
876 dpavlin 10
877 dpavlin 111 _log ">> /$1 $2 $3";
878     $_[KERNEL]->post( $irc => $1 => $2, $3 );
879 dpavlin 10 $res = '';
880    
881 dpavlin 8 } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
882    
883 dpavlin 7 my $nr = $1 || 10;
884    
885     my $sth = $dbh->prepare(qq{
886 dpavlin 40 select
887 dpavlin 57 trim(both '_' from nick) as nick,
888 dpavlin 40 count(*) as count,
889     sum(length(message)) as len
890     from log
891 dpavlin 57 group by trim(both '_' from nick)
892 dpavlin 40 order by len desc,count desc
893     limit $nr
894 dpavlin 7 });
895     $sth->execute();
896     $res = "Top $nr users: ";
897 dpavlin 8 my @users;
898 dpavlin 7 while (my $row = $sth->fetchrow_hashref) {
899 dpavlin 40 push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
900 dpavlin 7 }
901 dpavlin 8 $res .= join(" | ", @users);
902     } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
903    
904 dpavlin 50 my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
905    
906     foreach my $res (get_from_log( limit => $limit )) {
907 dpavlin 45 _log "last: $res";
908 dpavlin 109 $_[KERNEL]->post( $irc => privmsg => $nick, $res );
909 dpavlin 8 }
910    
911 dpavlin 11 $res = '';
912 dpavlin 8
913 dpavlin 21 } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
914 dpavlin 8
915 dpavlin 11 my $what = $2;
916 dpavlin 8
917 dpavlin 21 foreach my $res (get_from_log(
918     limit => 20,
919     search => $what,
920     )) {
921 dpavlin 45 _log "search [$what]: $res";
922 dpavlin 109 $_[KERNEL]->post( $irc => privmsg => $nick, $res );
923 dpavlin 8 }
924    
925     $res = '';
926 dpavlin 11
927 dpavlin 42 } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
928    
929     my ($what,$limit) = ($1,$2);
930     $limit ||= 100;
931    
932     my $stat;
933    
934     foreach my $res (get_from_log(
935     limit => $limit,
936     search => $what,
937     full_rows => 1,
938     )) {
939     while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
940     $stat->{vote}->{$1}++;
941     $stat->{from}->{ $res->{nick} }++;
942     }
943     }
944    
945     my @nicks;
946 dpavlin 43 foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
947     push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
948     "(" . $stat->{from}->{$nick} . ")"
949     );
950 dpavlin 42 }
951    
952     $res =
953 dpavlin 43 "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
954     " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
955 dpavlin 42 " from " . ( join(", ", @nicks) || 'nobody' );
956    
957 dpavlin 109 $_[KERNEL]->post( $irc => notice => $nick, $res );
958 dpavlin 43
959     } elsif ($msg =~ m/^ping/) {
960 dpavlin 109 $res = "ping = " . dump( $_stat->{ping} );
961 dpavlin 51 } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
962 dpavlin 50 if ( ! defined( $1 ) ) {
963     my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
964     $sth->execute( $nick, $channel );
965 dpavlin 52 $res = "config for $nick on $channel";
966 dpavlin 50 while ( my ($n,$v) = $sth->fetchrow_array ) {
967 dpavlin 52 $res .= " | $n = $v";
968 dpavlin 50 }
969 dpavlin 51 } elsif ( ! $2 ) {
970 dpavlin 50 my $val = meta( $nick, $channel, $1 );
971     $res = "current $1 = " . ( $val ? $val : 'undefined' );
972 dpavlin 51 } else {
973     my $validate = {
974     'last-size' => qr/^\d+/,
975     'twitter' => qr/^\w+\s+\w+/,
976     };
977    
978     my ( $op, $val ) = ( $1, $2 );
979    
980     if ( my $regex = $validate->{$op} ) {
981     if ( $val =~ $regex ) {
982     meta( $nick, $channel, $op, $val );
983     $res = "saved $op = $val";
984     } else {
985     $res = "config option $op = $val doesn't validate against $regex";
986     }
987     } else {
988     $res = "config option $op doesn't exist";
989     }
990 dpavlin 50 }
991 dpavlin 85 } elsif ($msg =~ m/^rss-update/) {
992     $res = rss_fetch_all( $_[KERNEL] );
993 dpavlin 91 } elsif ($msg =~ m/^rss-list/) {
994 dpavlin 97 my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
995 dpavlin 91 $sth->execute;
996     while (my @row = $sth->fetchrow_array) {
997 dpavlin 109 $_[KERNEL]->post( $irc => privmsg => $nick, join(' | ',@row) );
998 dpavlin 91 }
999     $res = '';
1000 dpavlin 117 } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
1001 dpavlin 97 my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
1002    
1003     my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
1004     $channel = $nick if $sub eq 'private';
1005    
1006 dpavlin 85 my $sql = {
1007 dpavlin 103 add => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
1008 dpavlin 85 # remove => qq{ delete from feeds where url = ? and name = ? },
1009 dpavlin 91 start => qq{ update feeds set active = true where url = ? },
1010     stop => qq{ update feeds set active = false where url = ? },
1011 dpavlin 117 clean => qq{ update feeds set last_update = now() - delay where url = ? },
1012 dpavlin 85 };
1013 dpavlin 97
1014 dpavlin 99 if ( $command eq 'add' && ! $channel ) {
1015     $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
1016     } elsif (my $q = $sql->{$command} ) {
1017 dpavlin 85 my $sth = $dbh->prepare( $q );
1018 dpavlin 97 my @data = ( $url );
1019     if ( $command eq 'add' ) {
1020     push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
1021     }
1022     warn "## $command SQL $q with ",dump( @data ),"\n";
1023 dpavlin 91 eval { $sth->execute( @data ) };
1024 dpavlin 97 if ($@) {
1025     $res = "ERROR: $@";
1026     } else {
1027 dpavlin 126 $res = "OK, RSS executed $command" . ( $sub ? "-$sub" : '' ) ." on $channel url $url";
1028 dpavlin 117 if ( $command eq 'clean' ) {
1029     my $seen = $_stat->{rss}->{seen} || die "no seen?";
1030     my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
1031     foreach my $c ( keys %$seen ) {
1032     my $c_hash = $seen->{$c} || die "no seen->{$c}";
1033     die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
1034     foreach my $link ( keys %$c_hash ) {
1035     next unless $link eq $want_link;
1036     _log "RSS removed seen $c $url $link";
1037     }
1038     }
1039 dpavlin 126 } elsif ( $command eq 'add' ) {
1040     rss_fetch_all( $_[KERNEL] );
1041 dpavlin 117 }
1042 dpavlin 97 }
1043     } else {
1044     $res = "ERROR: don't know what to do with: $msg";
1045 dpavlin 85 }
1046 dpavlin 117 } elsif ($msg =~ m/^rss-clean/) {
1047     # this makes sense because we didn't catch rss-clean http://... before!
1048     $_stat->{rss} = undef;
1049     $dbh->do( qq{ update feeds set last_update = now() - delay } );
1050 dpavlin 126 $res = rss_fetch_all( $_[KERNEL] );
1051 dpavlin 7 }
1052    
1053 dpavlin 8 if ($res) {
1054 dpavlin 45 _log ">> [$nick] $res";
1055 dpavlin 109 $_[KERNEL]->post( $irc => privmsg => $nick, $res );
1056 dpavlin 8 }
1057 dpavlin 7
1058 dpavlin 85 rss_check_updates( $_[KERNEL] );
1059 dpavlin 7 },
1060 dpavlin 107 irc_372 => sub {
1061     _log "<< motd",$_[ARG0],$_[ARG1];
1062     },
1063     irc_375 => sub {
1064     _log "<< motd", $_[ARG0], "start";
1065     },
1066     irc_376 => sub {
1067     _log "<< motd", $_[ARG0], "end";
1068     },
1069 dpavlin 114 # irc_433 => sub {
1070     # print "# irc_433: ",$_[ARG1], "\n";
1071     # warn "## indetify $NICK\n";
1072     # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1073     # },
1074     # irc_451 # please register
1075 dpavlin 10 irc_477 => sub {
1076 dpavlin 103 _log "<< irc_477: ",$_[ARG1];
1077 dpavlin 114 _log ">> IDENTIFY $NICK";
1078     $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1079 dpavlin 10 },
1080 dpavlin 7 irc_505 => sub {
1081 dpavlin 103 _log "<< irc_505: ",$_[ARG1];
1082 dpavlin 114 _log ">> register $NICK";
1083     $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1084     # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1085 dpavlin 109 # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1086     # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1087 dpavlin 8 },
1088     irc_registered => sub {
1089 dpavlin 109 _log "<< registered $NICK";
1090 dpavlin 10 },
1091 dpavlin 41 irc_disconnected => sub {
1092 dpavlin 103 _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1093     sleep($sleep_on_error);
1094 dpavlin 109 $_[KERNEL]->post( $irc => connect => {} );
1095 dpavlin 41 },
1096     irc_socketerr => sub {
1097 dpavlin 45 _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1098 dpavlin 41 sleep($sleep_on_error);
1099 dpavlin 109 $_[KERNEL]->post( $irc => connect => {} );
1100 dpavlin 41 },
1101 dpavlin 109 irc_notice => sub {
1102 dpavlin 116 _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1103     my $m = $_[ARG2];
1104     if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1105     _log ">> suggested to $1 $2";
1106     $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1107     } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1108     _log ">> registreted, so IDENTIFY";
1109 dpavlin 109 $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1110 dpavlin 116 } else {
1111 dpavlin 119 warn "## ignore $m\n" if $debug;
1112 dpavlin 109 }
1113     },
1114 dpavlin 103 irc_snotice => sub {
1115 dpavlin 116 _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1116 dpavlin 103 if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1117     warn ">> $1 | $2\n";
1118 dpavlin 109 $_[KERNEL]->post( $irc => lc($1) => $2);
1119 dpavlin 103 }
1120     },
1121 dpavlin 4 _child => sub {},
1122     _default => sub {
1123 dpavlin 45 _log sprintf "sID:%s %s %s",
1124     $_[SESSION]->ID, $_[ARG0],
1125 dpavlin 34 ref($_[ARG1]) eq "ARRAY" ? join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] }) :
1126     $_[ARG1] ? $_[ARG1] :
1127     "";
1128 dpavlin 4 0; # false for signals
1129     },
1130 dpavlin 122 rss_response => sub {
1131     my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1132     my $request_object = $request_packet->[0];
1133     my $response_object = $response_packet->[0];
1134    
1135     my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1136     if ( $row ) {
1137     $row->{xml} = $response_object->content;
1138 dpavlin 126 rss_parse_xml( $_[KERNEL], $row );
1139 dpavlin 122 } else {
1140     warn "## can't find rss->fetch for ", $request_object->uri;
1141     }
1142     },
1143 dpavlin 4 },
1144     );
1145    
1146 dpavlin 13 # http server
1147    
1148 dpavlin 114 _log "WEB archive at $url";
1149    
1150 dpavlin 13 my $httpd = POE::Component::Server::HTTP->new(
1151 dpavlin 70 Port => $http_port,
1152 dpavlin 83 PreHandler => {
1153     '/' => sub {
1154     $_[0]->header(Connection => 'close')
1155     }
1156     },
1157 dpavlin 13 ContentHandler => { '/' => \&root_handler },
1158     Headers => { Server => 'irc-logger' },
1159     );
1160    
1161     my $style = <<'_END_OF_STYLE_';
1162 dpavlin 16 p { margin: 0; padding: 0.1em; }
1163 dpavlin 13 .time, .channel { color: #808080; font-size: 60%; }
1164 dpavlin 28 .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
1165 dpavlin 20 .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1166 dpavlin 13 .message { color: #000000; font-size: 100%; }
1167 dpavlin 16 .search { float: right; }
1168 dpavlin 60 a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1169     a:hover.tag { border: 1px solid #eee }
1170     hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1171     /*
1172 dpavlin 20 .col-0 { background: #ffff66 }
1173     .col-1 { background: #a0ffff }
1174     .col-2 { background: #99ff99 }
1175     .col-3 { background: #ff9999 }
1176     .col-4 { background: #ff66ff }
1177 dpavlin 60 */
1178 dpavlin 65 .calendar { border: 1px solid red; width: 100%; }
1179     .month { border: 0px; width: 100%; }
1180 dpavlin 13 _END_OF_STYLE_
1181    
1182 dpavlin 70 $max_color = 0;
1183 dpavlin 20
1184 dpavlin 60 my @cols = qw(
1185     #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1186     #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1187     #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1188     #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1189     #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1190     );
1191    
1192     foreach my $c (@cols) {
1193     $style .= ".col-${max_color} { background: $c }\n";
1194     $max_color++;
1195     }
1196 dpavlin 114 _log "WEB defined $max_color colors for users...";
1197 dpavlin 60
1198 dpavlin 13 sub root_handler {
1199     my ($request, $response) = @_;
1200     $response->code(RC_OK);
1201 dpavlin 16
1202 dpavlin 83 # this doesn't seem to work, so moved to PreHandler
1203     #$response->header(Connection => 'close');
1204    
1205 dpavlin 73 return RC_OK if $request->uri =~ m/favicon.ico$/;
1206    
1207 dpavlin 16 my $q;
1208    
1209     if ( $request->method eq 'POST' ) {
1210     $q = new CGI::Simple( $request->content );
1211     } elsif ( $request->uri =~ /\?(.+)$/ ) {
1212     $q = new CGI::Simple( $1 );
1213     } else {
1214     $q = new CGI::Simple;
1215     }
1216    
1217     my $search = $q->param('search') || $q->param('grep') || '';
1218 dpavlin 108 my $r_url = $request->url;
1219 dpavlin 16
1220 dpavlin 108 my @commands = qw( tags last-tag follow stat );
1221     my $commands_re = join('|',@commands);
1222    
1223     if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1224 dpavlin 77 my $show = lc($1);
1225 dpavlin 79 my $nr = $2;
1226 dpavlin 77
1227 dpavlin 71 my $type = 'RSS'; # Atom
1228 dpavlin 70
1229 dpavlin 72 $response->content_type( 'application/' . lc($type) . '+xml' );
1230 dpavlin 70
1231     my $html = '<!-- error -->';
1232 dpavlin 74 #warn "create $type feed from ",dump( @last_tags );
1233 dpavlin 70
1234     my $feed = XML::Feed->new( $type );
1235 dpavlin 85 $feed->link( $url );
1236 dpavlin 70
1237 dpavlin 108 my $rc = RC_OK;
1238    
1239 dpavlin 77 if ( $show eq 'tags' ) {
1240 dpavlin 79 $nr ||= 50;
1241 dpavlin 77 $feed->title( "tags from $CHANNEL" );
1242     $feed->link( "$url/tags" );
1243     $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1244 dpavlin 70 my $feed_entry = XML::Feed::Entry->new($type);
1245 dpavlin 79 $feed_entry->title( "$nr tags from $CHANNEL" );
1246 dpavlin 77 $feed_entry->author( $NICK );
1247     $feed_entry->link( '/#tags' );
1248 dpavlin 75
1249 dpavlin 73 $feed_entry->content(
1250 dpavlin 77 qq{<![CDATA[<style type="text/css">}
1251     . $cloud->css
1252     . qq{</style>}
1253 dpavlin 79 . $cloud->html( $nr )
1254 dpavlin 77 . qq{]]>}
1255 dpavlin 70 );
1256     $feed->add_entry( $feed_entry );
1257 dpavlin 77
1258 dpavlin 79 } elsif ( $show eq 'last-tag' ) {
1259 dpavlin 77
1260 dpavlin 79 $nr ||= $last_x_tags;
1261 dpavlin 80 $nr = $last_x_tags if $nr > $last_x_tags;
1262 dpavlin 79
1263     $feed->title( "last $nr tagged messages from $CHANNEL" );
1264 dpavlin 77 $feed->description( "collects messages which have tags// in them" );
1265    
1266     foreach my $m ( @last_tags ) {
1267     # warn dump( $m );
1268     #my $tags = join(' ', @{$m->{tags}} );
1269     my $feed_entry = XML::Feed::Entry->new($type);
1270     $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1271     $feed_entry->author( $m->{nick} );
1272     $feed_entry->link( '/#' . $m->{id} );
1273     $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1274    
1275     my $message = $filter->{message}->( $m->{message} );
1276     $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1277 dpavlin 79 # warn "## message = $message\n";
1278 dpavlin 77
1279     #$feed_entry->summary(
1280     $feed_entry->content(
1281     "<![CDATA[$message]]>"
1282     );
1283     $feed_entry->category( join(', ', @{$m->{tags}}) );
1284     $feed->add_entry( $feed_entry );
1285 dpavlin 79
1286     $nr--;
1287     last if $nr <= 0;
1288    
1289 dpavlin 77 }
1290 dpavlin 79
1291 dpavlin 85 } elsif ( $show =~ m/^follow/ ) {
1292    
1293     $feed->title( "Feeds which this bot follows" );
1294    
1295     my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1296     $sth->execute;
1297     while (my $row = $sth->fetchrow_hashref) {
1298     my $feed_entry = XML::Feed::Entry->new($type);
1299     $feed_entry->title( $row->{name} );
1300     $feed_entry->link( $row->{url} );
1301     $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1302     $feed_entry->content(
1303     '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1304     );
1305     $feed->add_entry( $feed_entry );
1306     }
1307    
1308 dpavlin 108 } elsif ( $show =~ m/^stat/ ) {
1309    
1310 dpavlin 97 my $feed_entry = XML::Feed::Entry->new($type);
1311     $feed_entry->title( "Internal stats" );
1312     $feed_entry->content(
1313 dpavlin 108 '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1314 dpavlin 97 );
1315     $feed->add_entry( $feed_entry );
1316    
1317 dpavlin 79 } else {
1318 dpavlin 114 _log "WEB unknown rss request $r_url";
1319 dpavlin 108 $feed->title( "unknown $r_url" );
1320     foreach my $c ( @commands ) {
1321     my $feed_entry = XML::Feed::Entry->new($type);
1322     $feed_entry->title( "rss/$c" );
1323     $feed_entry->link( "$url/rss/$c" );
1324     $feed->add_entry( $feed_entry );
1325     }
1326     $rc = RC_DENY;
1327 dpavlin 70 }
1328    
1329     $response->content( $feed->as_xml );
1330 dpavlin 108 return $rc;
1331 dpavlin 70 }
1332    
1333     if ( $@ ) {
1334     warn "$@";
1335     }
1336    
1337 dpavlin 86 $response->content_type("text/html; charset=UTF-8");
1338 dpavlin 70
1339 dpavlin 35 my $html =
1340 dpavlin 77 qq{<html><head><title>$NICK</title><style type="text/css">$style}
1341     . $cloud->css
1342     . qq{</style></head><body>}
1343     . qq{
1344 dpavlin 32 <form method="post" class="search" action="/">
1345 dpavlin 16 <input type="text" name="search" value="$search" size="10">
1346     <input type="submit" value="search">
1347     </form>
1348 dpavlin 77 }
1349     . $cloud->html(500)
1350     . qq{<p>};
1351 dpavlin 76
1352     if ($request->url =~ m#/tags?#) {
1353     # nop
1354     } elsif ($request->url =~ m#/history#) {
1355 dpavlin 35 my $sth = $dbh->prepare(qq{
1356 dpavlin 65 select date(time) as date,count(*) as nr,sum(length(message)) as len
1357 dpavlin 35 from log
1358     group by date(time)
1359     order by date(time) desc
1360     });
1361     $sth->execute();
1362     my ($l_yyyy,$l_mm) = (0,0);
1363 dpavlin 65 $html .= qq{<table class="calendar"><tr>};
1364 dpavlin 35 my $cal;
1365 dpavlin 65 my $ord = 0;
1366 dpavlin 35 while (my $row = $sth->fetchrow_hashref) {
1367     # this is probably PostgreSQL specific, expects ISO date
1368     my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1369     if ($yyyy != $l_yyyy || $mm != $l_mm) {
1370 dpavlin 65 if ( $cal ) {
1371     $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1372     $ord++;
1373     $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1374     }
1375 dpavlin 35 $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1376 dpavlin 65 $cal->border(1);
1377     $cal->width('30%');
1378     $cal->cellheight('5em');
1379     $cal->tableclass('month');
1380     #$cal->cellclass('day');
1381     $cal->sunday('SUN');
1382     $cal->saturday('SAT');
1383     $cal->weekdays('MON','TUE','WED','THU','FRI');
1384 dpavlin 35 ($l_yyyy,$l_mm) = ($yyyy,$mm);
1385     }
1386 dpavlin 79 $cal->setcontent($dd, qq[
1387 dpavlin 73 <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1388 dpavlin 89 ]) if $cal;
1389 dpavlin 65
1390 dpavlin 35 }
1391 dpavlin 65 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1392 dpavlin 35
1393     } else {
1394     $html .= join("</p><p>",
1395 dpavlin 13 get_from_log(
1396 dpavlin 68 limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1397 dpavlin 28 search => $search || undef,
1398 dpavlin 29 tag => $q->param('tag') || undef,
1399 dpavlin 68 date => $q->param('date') || undef,
1400 dpavlin 13 fmt => {
1401 dpavlin 35 date => sub {
1402     my $date = shift || return;
1403 dpavlin 73 qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1404 dpavlin 35 },
1405 dpavlin 13 time => '<span class="time">%s</span> ',
1406     time_channel => '<span class="channel">%s %s</span> ',
1407 dpavlin 20 nick => '%s:&nbsp;',
1408     me_nick => '***%s&nbsp;',
1409 dpavlin 13 message => '<span class="message">%s</span>',
1410     },
1411 dpavlin 70 filter => $filter,
1412 dpavlin 13 )
1413 dpavlin 35 );
1414     }
1415    
1416     $html .= qq{</p>
1417     <hr/>
1418     <p>See <a href="/history">history</a> of all messages.</p>
1419     </body></html>};
1420    
1421 dpavlin 123 $response->content( decode('utf-8',$html) );
1422 dpavlin 74 warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1423 dpavlin 13 return RC_OK;
1424     }
1425    
1426 dpavlin 4 POE::Kernel->run;

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26