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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26