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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26