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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26