/[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 105 - (hide annotations)
Sun Mar 9 19:13:16 2008 UTC (16 years ago) by dpavlin
File MIME type: text/plain
File size: 32348 byte(s)
don't roll multiple /me messages (including rss announce) into single line
for nicer archive on web
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 85 my $_rss;
634    
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 97 next if $_rss->{$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 104 # FIXME bug! should be save_message
685     # save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
686 dpavlin 97 $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
687     my ( $type, $to ) = ( 'notice', $args->{channel} );
688     ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
689     _log(">> $type $to |", $msg);
690     $args->{kernel}->post( $IRC_ALIAS => $type => $to, $msg );
691 dpavlin 85 $updates++;
692     }
693     }
694    
695     my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
696     $sql .= qq{, updates = updates + $updates } if $updates;
697     $sql .= qq{where id = } . $args->{id};
698 dpavlin 86 eval { $dbh->do( $sql ) };
699 dpavlin 85
700 dpavlin 87 _log "RSS got $total items of which $updates new";
701    
702 dpavlin 85 return $updates;
703     }
704    
705     sub rss_fetch_all {
706     my $kernel = shift;
707     my $sql = qq{
708 dpavlin 97 select id, url, name, channel, nick, private
709 dpavlin 85 from feeds
710     where active is true
711     };
712     # limit to newer feeds only if we are not sending messages out
713     $sql .= qq{ and last_update + delay < now() } if $kernel;
714     my $sth = $dbh->prepare( $sql );
715     $sth->execute();
716     warn "# ",$sth->rows," active RSS feeds\n";
717     my $count = 0;
718     while (my $row = $sth->fetchrow_hashref) {
719     $row->{kernel} = $kernel if $kernel;
720     $count += rss_fetch( $row );
721     }
722     return "OK, fetched $count posts from " . $sth->rows . " feeds";
723     }
724    
725    
726     sub rss_check_updates {
727     my $kernel = shift;
728 dpavlin 95 $_rss->{last_poll} ||= time();
729     my $dt = time() - $_rss->{last_poll};
730     warn "## rss_check_updates $dt > $rss_min_delay\n";
731     if ( $dt > $rss_min_delay ) {
732     $_rss->{last_poll} = time();
733 dpavlin 85 _log rss_fetch_all( $kernel );
734     }
735     }
736    
737     # seed rss seen cache so we won't send out all items on startup
738     _log rss_fetch_all;
739    
740 dpavlin 37 #
741     # POE handing part
742     #
743    
744 dpavlin 43 my $ping; # ping stats
745 dpavlin 37
746     POE::Component::IRC->new($IRC_ALIAS);
747    
748 dpavlin 85 POE::Session->create( inline_states => {
749     _start => sub {
750 dpavlin 7 $_[KERNEL]->post($IRC_ALIAS => register => 'all');
751     $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
752 dpavlin 4 },
753 dpavlin 9 irc_255 => sub { # server is done blabbing
754 dpavlin 7 $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
755 dpavlin 11 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
756 dpavlin 4 },
757     irc_public => sub {
758 dpavlin 7 my $kernel = $_[KERNEL];
759     my $nick = (split /!/, $_[ARG0])[0];
760     my $channel = $_[ARG1]->[0];
761     my $msg = $_[ARG2];
762 dpavlin 4
763 dpavlin 70 save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
764 dpavlin 50 meta( $nick, $channel, 'last-msg', $msg );
765 dpavlin 95 rss_check_updates( $kernel );
766 dpavlin 4 },
767 dpavlin 19 irc_ctcp_action => sub {
768     my $kernel = $_[KERNEL];
769     my $nick = (split /!/, $_[ARG0])[0];
770     my $channel = $_[ARG1]->[0];
771     my $msg = $_[ARG2];
772    
773 dpavlin 70 save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
774 dpavlin 50
775 dpavlin 54 if ( $use_twitter ) {
776 dpavlin 58 if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
777 dpavlin 54 my ($login,$passwd) = split(/\s+/,$twitter,2);
778     _log("sending twitter for $nick/$login on $channel ");
779     my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
780     $bot->update("<${channel}> $msg");
781     }
782 dpavlin 50 }
783    
784 dpavlin 19 },
785 dpavlin 43 irc_ping => sub {
786 dpavlin 84 _log( "pong ", $_[ARG0] );
787 dpavlin 48 $ping->{ $_[ARG0] }++;
788 dpavlin 85 rss_check_updates( $_[KERNEL] );
789 dpavlin 43 },
790     irc_invite => sub {
791     my $kernel = $_[KERNEL];
792     my $nick = (split /!/, $_[ARG0])[0];
793     my $channel = $_[ARG1];
794    
795 dpavlin 85 _log "invited to $channel by $nick";
796 dpavlin 43
797     $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
798     $_[KERNEL]->post($IRC_ALIAS => join => $channel);
799    
800     },
801 dpavlin 7 irc_msg => sub {
802     my $kernel = $_[KERNEL];
803     my $nick = (split /!/, $_[ARG0])[0];
804     my $msg = $_[ARG2];
805 dpavlin 50 my $channel = $_[ARG1]->[0];
806 dpavlin 7
807 dpavlin 8 my $res = "unknown command '$msg', try /msg $NICK help!";
808 dpavlin 11 my @out;
809 dpavlin 7
810 dpavlin 45 _log "<< $msg";
811 dpavlin 7
812 dpavlin 8 if ($msg =~ m/^help/i) {
813 dpavlin 7
814 dpavlin 11 $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
815 dpavlin 8
816 dpavlin 10 } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
817    
818 dpavlin 45 _log ">> /msg $1 $2";
819 dpavlin 10 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
820     $res = '';
821    
822 dpavlin 8 } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
823    
824 dpavlin 7 my $nr = $1 || 10;
825    
826     my $sth = $dbh->prepare(qq{
827 dpavlin 40 select
828 dpavlin 57 trim(both '_' from nick) as nick,
829 dpavlin 40 count(*) as count,
830     sum(length(message)) as len
831     from log
832 dpavlin 57 group by trim(both '_' from nick)
833 dpavlin 40 order by len desc,count desc
834     limit $nr
835 dpavlin 7 });
836     $sth->execute();
837     $res = "Top $nr users: ";
838 dpavlin 8 my @users;
839 dpavlin 7 while (my $row = $sth->fetchrow_hashref) {
840 dpavlin 40 push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
841 dpavlin 7 }
842 dpavlin 8 $res .= join(" | ", @users);
843     } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
844    
845 dpavlin 50 my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
846    
847     foreach my $res (get_from_log( limit => $limit )) {
848 dpavlin 45 _log "last: $res";
849 dpavlin 11 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
850 dpavlin 8 }
851    
852 dpavlin 11 $res = '';
853 dpavlin 8
854 dpavlin 21 } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
855 dpavlin 8
856 dpavlin 11 my $what = $2;
857 dpavlin 8
858 dpavlin 21 foreach my $res (get_from_log(
859     limit => 20,
860     search => $what,
861     )) {
862 dpavlin 45 _log "search [$what]: $res";
863 dpavlin 8 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
864     }
865    
866     $res = '';
867 dpavlin 11
868 dpavlin 42 } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
869    
870     my ($what,$limit) = ($1,$2);
871     $limit ||= 100;
872    
873     my $stat;
874    
875     foreach my $res (get_from_log(
876     limit => $limit,
877     search => $what,
878     full_rows => 1,
879     )) {
880     while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
881     $stat->{vote}->{$1}++;
882     $stat->{from}->{ $res->{nick} }++;
883     }
884     }
885    
886     my @nicks;
887 dpavlin 43 foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
888     push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
889     "(" . $stat->{from}->{$nick} . ")"
890     );
891 dpavlin 42 }
892    
893     $res =
894 dpavlin 43 "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
895     " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
896 dpavlin 42 " from " . ( join(", ", @nicks) || 'nobody' );
897    
898 dpavlin 43 $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
899    
900     } elsif ($msg =~ m/^ping/) {
901     $res = "ping = " . dump( $ping );
902 dpavlin 51 } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
903 dpavlin 50 if ( ! defined( $1 ) ) {
904     my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
905     $sth->execute( $nick, $channel );
906 dpavlin 52 $res = "config for $nick on $channel";
907 dpavlin 50 while ( my ($n,$v) = $sth->fetchrow_array ) {
908 dpavlin 52 $res .= " | $n = $v";
909 dpavlin 50 }
910 dpavlin 51 } elsif ( ! $2 ) {
911 dpavlin 50 my $val = meta( $nick, $channel, $1 );
912     $res = "current $1 = " . ( $val ? $val : 'undefined' );
913 dpavlin 51 } else {
914     my $validate = {
915     'last-size' => qr/^\d+/,
916     'twitter' => qr/^\w+\s+\w+/,
917     };
918    
919     my ( $op, $val ) = ( $1, $2 );
920    
921     if ( my $regex = $validate->{$op} ) {
922     if ( $val =~ $regex ) {
923     meta( $nick, $channel, $op, $val );
924     $res = "saved $op = $val";
925     } else {
926     $res = "config option $op = $val doesn't validate against $regex";
927     }
928     } else {
929     $res = "config option $op doesn't exist";
930     }
931 dpavlin 50 }
932 dpavlin 85 } elsif ($msg =~ m/^rss-update/) {
933     $res = rss_fetch_all( $_[KERNEL] );
934     } elsif ($msg =~ m/^rss-clean/) {
935     $_rss = undef;
936 dpavlin 90 $dbh->do( qq{ update feeds set last_update = now() - delay } );
937 dpavlin 85 $res = "OK, cleaned RSS cache";
938 dpavlin 91 } elsif ($msg =~ m/^rss-list/) {
939 dpavlin 97 my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
940 dpavlin 91 $sth->execute;
941     while (my @row = $sth->fetchrow_array) {
942     $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );
943     }
944     $res = '';
945 dpavlin 97 } elsif ($msg =~ m!^rss-(add|remove|stop|start)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
946     my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
947    
948     my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
949     $channel = $nick if $sub eq 'private';
950    
951 dpavlin 85 my $sql = {
952 dpavlin 103 add => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
953 dpavlin 85 # remove => qq{ delete from feeds where url = ? and name = ? },
954 dpavlin 91 start => qq{ update feeds set active = true where url = ? },
955     stop => qq{ update feeds set active = false where url = ? },
956 dpavlin 85 };
957 dpavlin 97
958 dpavlin 99 if ( $command eq 'add' && ! $channel ) {
959     $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
960     } elsif (my $q = $sql->{$command} ) {
961 dpavlin 85 my $sth = $dbh->prepare( $q );
962 dpavlin 97 my @data = ( $url );
963     if ( $command eq 'add' ) {
964     push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
965     }
966     warn "## $command SQL $q with ",dump( @data ),"\n";
967 dpavlin 91 eval { $sth->execute( @data ) };
968 dpavlin 97 if ($@) {
969     $res = "ERROR: $@";
970     } else {
971     $res = "OK, RSS [$command|$sub|$url|$arg]";
972     }
973     } else {
974     $res = "ERROR: don't know what to do with: $msg";
975 dpavlin 85 }
976 dpavlin 7 }
977    
978 dpavlin 8 if ($res) {
979 dpavlin 45 _log ">> [$nick] $res";
980 dpavlin 8 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
981     }
982 dpavlin 7
983 dpavlin 85 rss_check_updates( $_[KERNEL] );
984 dpavlin 7 },
985 dpavlin 10 irc_477 => sub {
986 dpavlin 103 _log "<< irc_477: ",$_[ARG1];
987 dpavlin 10 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
988     },
989 dpavlin 7 irc_505 => sub {
990 dpavlin 103 _log "<< irc_505: ",$_[ARG1];
991 dpavlin 7 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
992 dpavlin 10 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
993     # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
994 dpavlin 8 },
995     irc_registered => sub {
996 dpavlin 103 _log "## registrated $NICK, /msg nickserv IDENTIFY $NICK";
997 dpavlin 7 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
998 dpavlin 10 },
999 dpavlin 41 irc_disconnected => sub {
1000 dpavlin 103 _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1001     sleep($sleep_on_error);
1002     $_[KERNEL]->post( $IRC_ALIAS => connect => $CONNECT);
1003 dpavlin 41 },
1004     irc_socketerr => sub {
1005 dpavlin 45 _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1006 dpavlin 41 sleep($sleep_on_error);
1007 dpavlin 103 $_[KERNEL]->post( $IRC_ALIAS => connect => $CONNECT);
1008 dpavlin 41 },
1009 dpavlin 11 # irc_433 => sub {
1010     # print "# irc_433: ",$_[ARG1], "\n";
1011     # warn "## indetify $NICK\n";
1012     # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
1013     # },
1014 dpavlin 103 # irc_451 # please register
1015     irc_snotice => sub {
1016     _log "<< snotice",$_[ARG0];
1017     if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1018     warn ">> $1 | $2\n";
1019     $_[KERNEL]->post( $IRC_ALIAS => lc($1) => $2);
1020     }
1021     },
1022 dpavlin 4 _child => sub {},
1023     _default => sub {
1024 dpavlin 45 _log sprintf "sID:%s %s %s",
1025     $_[SESSION]->ID, $_[ARG0],
1026 dpavlin 34 ref($_[ARG1]) eq "ARRAY" ? join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] }) :
1027     $_[ARG1] ? $_[ARG1] :
1028     "";
1029 dpavlin 4 0; # false for signals
1030     },
1031     },
1032     );
1033    
1034 dpavlin 13 # http server
1035    
1036     my $httpd = POE::Component::Server::HTTP->new(
1037 dpavlin 70 Port => $http_port,
1038 dpavlin 83 PreHandler => {
1039     '/' => sub {
1040     $_[0]->header(Connection => 'close')
1041     }
1042     },
1043 dpavlin 13 ContentHandler => { '/' => \&root_handler },
1044     Headers => { Server => 'irc-logger' },
1045     );
1046    
1047     my $style = <<'_END_OF_STYLE_';
1048 dpavlin 16 p { margin: 0; padding: 0.1em; }
1049 dpavlin 13 .time, .channel { color: #808080; font-size: 60%; }
1050 dpavlin 28 .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
1051 dpavlin 20 .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1052 dpavlin 13 .message { color: #000000; font-size: 100%; }
1053 dpavlin 16 .search { float: right; }
1054 dpavlin 60 a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1055     a:hover.tag { border: 1px solid #eee }
1056     hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1057     /*
1058 dpavlin 20 .col-0 { background: #ffff66 }
1059     .col-1 { background: #a0ffff }
1060     .col-2 { background: #99ff99 }
1061     .col-3 { background: #ff9999 }
1062     .col-4 { background: #ff66ff }
1063 dpavlin 60 */
1064 dpavlin 65 .calendar { border: 1px solid red; width: 100%; }
1065     .month { border: 0px; width: 100%; }
1066 dpavlin 13 _END_OF_STYLE_
1067    
1068 dpavlin 70 $max_color = 0;
1069 dpavlin 20
1070 dpavlin 60 my @cols = qw(
1071     #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1072     #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1073     #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1074     #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1075     #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1076     );
1077    
1078     foreach my $c (@cols) {
1079     $style .= ".col-${max_color} { background: $c }\n";
1080     $max_color++;
1081     }
1082     warn "defined $max_color colors for users...\n";
1083    
1084 dpavlin 13 sub root_handler {
1085     my ($request, $response) = @_;
1086     $response->code(RC_OK);
1087 dpavlin 16
1088 dpavlin 83 # this doesn't seem to work, so moved to PreHandler
1089     #$response->header(Connection => 'close');
1090    
1091 dpavlin 73 return RC_OK if $request->uri =~ m/favicon.ico$/;
1092    
1093 dpavlin 16 my $q;
1094    
1095     if ( $request->method eq 'POST' ) {
1096     $q = new CGI::Simple( $request->content );
1097     } elsif ( $request->uri =~ /\?(.+)$/ ) {
1098     $q = new CGI::Simple( $1 );
1099     } else {
1100     $q = new CGI::Simple;
1101     }
1102    
1103     my $search = $q->param('search') || $q->param('grep') || '';
1104    
1105 dpavlin 85 if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1106 dpavlin 77 my $show = lc($1);
1107 dpavlin 79 my $nr = $2;
1108 dpavlin 77
1109 dpavlin 71 my $type = 'RSS'; # Atom
1110 dpavlin 70
1111 dpavlin 72 $response->content_type( 'application/' . lc($type) . '+xml' );
1112 dpavlin 70
1113     my $html = '<!-- error -->';
1114 dpavlin 74 #warn "create $type feed from ",dump( @last_tags );
1115 dpavlin 70
1116     my $feed = XML::Feed->new( $type );
1117 dpavlin 85 $feed->link( $url );
1118 dpavlin 70
1119 dpavlin 77 if ( $show eq 'tags' ) {
1120 dpavlin 79 $nr ||= 50;
1121 dpavlin 77 $feed->title( "tags from $CHANNEL" );
1122     $feed->link( "$url/tags" );
1123     $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1124 dpavlin 70 my $feed_entry = XML::Feed::Entry->new($type);
1125 dpavlin 79 $feed_entry->title( "$nr tags from $CHANNEL" );
1126 dpavlin 77 $feed_entry->author( $NICK );
1127     $feed_entry->link( '/#tags' );
1128 dpavlin 75
1129 dpavlin 73 $feed_entry->content(
1130 dpavlin 77 qq{<![CDATA[<style type="text/css">}
1131     . $cloud->css
1132     . qq{</style>}
1133 dpavlin 79 . $cloud->html( $nr )
1134 dpavlin 77 . qq{]]>}
1135 dpavlin 70 );
1136     $feed->add_entry( $feed_entry );
1137 dpavlin 77
1138 dpavlin 79 } elsif ( $show eq 'last-tag' ) {
1139 dpavlin 77
1140 dpavlin 79 $nr ||= $last_x_tags;
1141 dpavlin 80 $nr = $last_x_tags if $nr > $last_x_tags;
1142 dpavlin 79
1143     $feed->title( "last $nr tagged messages from $CHANNEL" );
1144 dpavlin 77 $feed->description( "collects messages which have tags// in them" );
1145    
1146     foreach my $m ( @last_tags ) {
1147     # warn dump( $m );
1148     #my $tags = join(' ', @{$m->{tags}} );
1149     my $feed_entry = XML::Feed::Entry->new($type);
1150     $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1151     $feed_entry->author( $m->{nick} );
1152     $feed_entry->link( '/#' . $m->{id} );
1153     $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1154    
1155     my $message = $filter->{message}->( $m->{message} );
1156     $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1157 dpavlin 79 # warn "## message = $message\n";
1158 dpavlin 77
1159     #$feed_entry->summary(
1160     $feed_entry->content(
1161     "<![CDATA[$message]]>"
1162     );
1163     $feed_entry->category( join(', ', @{$m->{tags}}) );
1164     $feed->add_entry( $feed_entry );
1165 dpavlin 79
1166     $nr--;
1167     last if $nr <= 0;
1168    
1169 dpavlin 77 }
1170 dpavlin 79
1171 dpavlin 85 } elsif ( $show =~ m/^follow/ ) {
1172    
1173     $feed->title( "Feeds which this bot follows" );
1174    
1175     my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1176     $sth->execute;
1177     while (my $row = $sth->fetchrow_hashref) {
1178     my $feed_entry = XML::Feed::Entry->new($type);
1179     $feed_entry->title( $row->{name} );
1180     $feed_entry->link( $row->{url} );
1181     $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1182     $feed_entry->content(
1183     '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1184     );
1185     $feed->add_entry( $feed_entry );
1186     }
1187    
1188 dpavlin 97 my $feed_entry = XML::Feed::Entry->new($type);
1189     $feed_entry->title( "Internal stats" );
1190     $feed_entry->content(
1191     '<![CDATA[<pre>' . dump( $_rss ) . '</pre>]]>'
1192     );
1193     $feed->add_entry( $feed_entry );
1194    
1195 dpavlin 79 } else {
1196 dpavlin 85 _log "unknown rss request ",$request->url;
1197 dpavlin 79 return RC_DENY;
1198 dpavlin 70 }
1199    
1200     $response->content( $feed->as_xml );
1201     return RC_OK;
1202     }
1203    
1204     if ( $@ ) {
1205     warn "$@";
1206     }
1207    
1208 dpavlin 86 $response->content_type("text/html; charset=UTF-8");
1209 dpavlin 70
1210 dpavlin 35 my $html =
1211 dpavlin 77 qq{<html><head><title>$NICK</title><style type="text/css">$style}
1212     . $cloud->css
1213     . qq{</style></head><body>}
1214     . qq{
1215 dpavlin 32 <form method="post" class="search" action="/">
1216 dpavlin 16 <input type="text" name="search" value="$search" size="10">
1217     <input type="submit" value="search">
1218     </form>
1219 dpavlin 77 }
1220     . $cloud->html(500)
1221     . qq{<p>};
1222 dpavlin 76
1223     if ($request->url =~ m#/tags?#) {
1224     # nop
1225     } elsif ($request->url =~ m#/history#) {
1226 dpavlin 35 my $sth = $dbh->prepare(qq{
1227 dpavlin 65 select date(time) as date,count(*) as nr,sum(length(message)) as len
1228 dpavlin 35 from log
1229     group by date(time)
1230     order by date(time) desc
1231     });
1232     $sth->execute();
1233     my ($l_yyyy,$l_mm) = (0,0);
1234 dpavlin 65 $html .= qq{<table class="calendar"><tr>};
1235 dpavlin 35 my $cal;
1236 dpavlin 65 my $ord = 0;
1237 dpavlin 35 while (my $row = $sth->fetchrow_hashref) {
1238     # this is probably PostgreSQL specific, expects ISO date
1239     my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1240     if ($yyyy != $l_yyyy || $mm != $l_mm) {
1241 dpavlin 65 if ( $cal ) {
1242     $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1243     $ord++;
1244     $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1245     }
1246 dpavlin 35 $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1247 dpavlin 65 $cal->border(1);
1248     $cal->width('30%');
1249     $cal->cellheight('5em');
1250     $cal->tableclass('month');
1251     #$cal->cellclass('day');
1252     $cal->sunday('SUN');
1253     $cal->saturday('SAT');
1254     $cal->weekdays('MON','TUE','WED','THU','FRI');
1255 dpavlin 35 ($l_yyyy,$l_mm) = ($yyyy,$mm);
1256     }
1257 dpavlin 79 $cal->setcontent($dd, qq[
1258 dpavlin 73 <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1259 dpavlin 89 ]) if $cal;
1260 dpavlin 65
1261 dpavlin 35 }
1262 dpavlin 65 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1263 dpavlin 35
1264     } else {
1265     $html .= join("</p><p>",
1266 dpavlin 13 get_from_log(
1267 dpavlin 68 limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1268 dpavlin 28 search => $search || undef,
1269 dpavlin 29 tag => $q->param('tag') || undef,
1270 dpavlin 68 date => $q->param('date') || undef,
1271 dpavlin 13 fmt => {
1272 dpavlin 35 date => sub {
1273     my $date = shift || return;
1274 dpavlin 73 qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1275 dpavlin 35 },
1276 dpavlin 13 time => '<span class="time">%s</span> ',
1277     time_channel => '<span class="channel">%s %s</span> ',
1278 dpavlin 20 nick => '%s:&nbsp;',
1279     me_nick => '***%s&nbsp;',
1280 dpavlin 13 message => '<span class="message">%s</span>',
1281     },
1282 dpavlin 70 filter => $filter,
1283 dpavlin 13 )
1284 dpavlin 35 );
1285     }
1286    
1287     $html .= qq{</p>
1288     <hr/>
1289     <p>See <a href="/history">history</a> of all messages.</p>
1290     </body></html>};
1291    
1292     $response->content( $html );
1293 dpavlin 74 warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1294 dpavlin 13 return RC_OK;
1295     }
1296    
1297 dpavlin 4 POE::Kernel->run;

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26