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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26