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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26