mws/trunk/httpd.pl

#!/usr/bin/perl

# based on post 
# http://www.mail-archive.com/libwww@perl.org/msg04750.html

BEGIN {
        my $basedir = readlink($0) || $0; $basedir =~ s#/[^/]+$##;
        unshift(@INC, $basedir);
}

use strict;
use warnings;
use MWS::SWISH;
#use MWS::Plucene;
use HTTP::Daemon;
use HTTP::Status;
use IO::String;
use CGI::Lite;
use Template;
use URI::Escape;

use Data::Dumper;

my $debug = 1;

my $config_file = shift @ARGV || 'global.conf';

if (! -f $config_file) {
        print qq{Usage: $0 [/path/to/local.conf]

If local.conf is not specified, global.conf in current directory will
be used.
};
        exit 1;
}

my $mws = MWS::SWISH->new(config_file => $config_file);
#my $mws = MWS::Plucene->new(config_file => $config_file, debug => $debug);

my ($local_addr,$local_port) = ('127.0.0.1',6969);

my $listen = $mws->{config}->val('global', 'listen');

print STDERR "using listen $listen\n" if ($listen);

if ($listen && $listen =~ m/:/) {
        ($local_addr,$local_port) = split(/:/,$listen,2);
} elsif ($listen) {
        $local_addr = $listen;
}

my $d = HTTP::Daemon->new(
        Reuse => 1,
        LocalAddr => $local_addr,
        LocalPort => $local_port,
) || die "can't create HTTP::Daemon on $local_addr:$local_port: $!";

my $cgi = new CGI::Lite;
my $tt = Template->new({
        INCLUDE_PATH => $mws->{config}->val('global', 'templates'),
        FILTERS => {
                'body5' => \&body5_filter,
                'body' => \&body_filter,
        },
        EVAL_PERL => 1,
});

my $static_html = $mws->{config}->val('global', 'static_html');

print "Web server ready at: ", $d->url, "\n";


while ( my $c = $d->accept ) {
        while ( my $r = $c->get_request ) {

                # environs that a webserver should set.
                $ENV{'REQUEST_METHOD'}    = $r->method;
                $ENV{'GATEWAY_INTERFACE'} = "CGI/1.0";
                $ENV{'SERVER_PROTOCOL'}   = $r->protocol;
                $ENV{'CONTENT_TYPE'}      = $r->content_type;

                # this part is based on CGI::Lite

                $cgi->close_all_files();
                $cgi->{web_data}       = {};
                $cgi->{ordered_keys}   = [];
                $cgi->{all_handles}    = [];
                $cgi->{error_status}   = 0;
                $cgi->{error_message}  = undef;

                if ( $r->method eq 'GET' || $r->uri =~ /\?/ ) {
                        my $query_string = $r->uri;
                        $query_string =~ s/[^\?]+\?(.*)/$1/;
                        $cgi->_decode_url_encoded_data (\$query_string, 'form');

                } elsif ( $r->method eq 'POST' ) {

                        if ($r->content_type eq 'application/x-www-form-urlencoded') {
#                               local $^W = 0;
                                $cgi->_decode_url_encoded_data (\$r->content, 'form');
                        } elsif ($r->content_type =~ /multipart\/form-data/) {
                                my ($boundary) = $r->content_type =~ /boundary=(\S+)$/;
                                $cgi->_parse_multipart_data ($r->content_length, $boundary);
                        }
                } else {
                         $c->send_error(RC_FORBIDDEN);
                }

                my $param = $cgi->{web_data};
                my $url = $r->url->path;

                # XXX LOG
                print $r->method," ",$url,"\n";
                print Dumper($param,$mws->{counter}),"\n" if ($debug);

                # is this static page?
                if ($static_html && -f "$static_html/$url") {
                        print "static file: $static_html/$url\n" if ($debug);
                        $c->send_file_response("$static_html/$url");
                        $c->close;
                        next;
                }

                # template file name (use ?format=html as default)
                my $tpl_file = 'master.';
                $tpl_file .= $param->{'format'} || 'html';

                # parse date from url
                my ($yyyy,$mm,$dd) = $mws->yyyymmdd;

                my $yyyymm;

                my $date_limit;

                if ($url =~ m,^/(\d{4})[/-](\d+)[/-](\d+),) {
                        ($yyyy, $mm, $dd) = $mws->fmtdate($1,$2,$3);
                         $date_limit = "$yyyy-$mm-$dd";
                } elsif ($url =~ m,^/(\d{4})[/-](\d+),) {
                        ($yyyy,$mm) = $mws->fmtdate($1,$2);
                        $date_limit = "$yyyy-$mm";
                } elsif ($url =~ m,^/(\d{4}),) {
                        $date_limit = $mws->fmtdate($1);
                }

                #
                # implement functionality and generate HTML
                #
                my $html;

                if ($param->{'search_val'} && $param->{'search_fld'} && !$param->{'search'}) {
                        $param->{'search'} = $param->{'search_fld'}.":".$param->{'search_val'};
                } elsif ($param->{'search'}) {
                        ($param->{'search_fld'}, $param->{'search_val'}) = split(/:/,$param->{'search'},2);
                }

                my $tpl_var = {
                        param   => $param,
                        yyyy    => $yyyy,
                        mm      => $mm,
                        dd      => $dd,
                        date_limit => $date_limit,
                };

                # is this access to root of web server?
                if ($url eq "/" && !$param->{'search'}) {
                        # if first access, go to current year
                        $date_limit = $mws->fmtdate($yyyy);
                        $param->{sort_by} = "date desc";
                }

                # ?show_id=XXXXxxxx___message_id___xxxxXXXX
                if ($param->{'show_id'}) {

                        $mws->reset_counters;
                        my $row = $mws->fetch_result_by_id($param->{'show_id'});
                        $tpl_var->{message} = $row;
                } elsif ($param->{'search'} || $date_limit) {

                        # show search results
                        # ?search=foo:bar

                        my @search;
                        push @search, $param->{'search'} if ($param->{'search'});

                        if ($date_limit) {
                                push @search, "and" if (@search);
                                push @search, "date:\"$date_limit\"";
                        }

                        if ($param->{sort_by}) {
                                push @search, "sort:".$param->{sort_by};
                        }

                        print STDERR "search: ",join(" ",@search),"\n";

                        my $results = $mws->search(@search);
                        my @res = $mws->fetch_all_results();

                        $tpl_var->{results} = \@res if (@res);
                        $tpl_var->{total_hits} = $mws->{total_hits} || 0;

                        # no hits, offer suggestions
                        if (! $tpl_var->{results}) {
                                @{$tpl_var->{apropos}} = $mws->apropos_index($param->{'search_fld'}, $param->{'search_val'});
                        }

                }


                # push counters to template
                foreach my $f (qw(from to cc bcc folder)) {
                        my $h = $mws->counter($f) || next;
                        my @a;
                        foreach my $k (sort { $h->{$b}->{usage} <=> $h->{$a}->{usage} } keys %$h) {
                                push @a, $h->{$k};
                        }
                        $tpl_var->{counters}->{$f} = [ @a ] if (@a);
                }

                # push calendar in template
                $tpl_var->{calendar} = $mws->counter('calendar');

                $tt->process($tpl_file, $tpl_var, \$html) || die $tt->error();

                #
                # send HTMLto client
                #

                my $res = HTTP::Response->new(RC_OK);
                $res->header( 'Content-type' => 'text/html; charset=ISO-8859-2' );
                $res->content($html);
                $c->send_response($res);

                $c->close;
        }
        undef($c);
}

# template toolkit filter

sub html_escape($) {
        my $text = shift || return;

        # don't re-escape html
        #return $text if ($text =~ /&(?:lt|gt|amp|quot);/);

        # Escape <, >, & and ", and to produce valid XML
        my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
        my $escape_re  = join '|' => keys %escape;

        $text =~ s/($escape_re)/$escape{$1}/gs;

        while ($text =~ s/#-#(quote|signature)(\d*)##(.+?)##\1\2#-#/<span class="$1">$3<\/span>/gs) { } ;

        return $text;
}

#use Text::Context::EitherSide;

sub body5_filter {
        my $text = shift;

        # remove quote
        $text =~ s/^[\>:\|=]+[^\n\r]*[\n\r]*$/#-q-#/msg;
        # remove quote author
        $text =~ s/[\n\r]+[^\n\r]+:\s*(?:#-q-#[\n\r*])+//gs;
        $text =~ s/^[^\n\r]+:\s*(?:#-q-#[\n\r]*)+//gs;
        $text =~ s/#-q-#[\n\r]*//gs;
        # outlook quoting
        $text =~ s/(\s*--+\s*Original\s+Message\s*--+.*)$//si;
        $text =~ s/(\s*--+\s*Forwarded\s+message.+\s*--+.*)$//si;

        # remove signature
        $text =~ s/[\n\r]+--\s*[\n\r]+.*$//s;

        # compress cr/lf
        $text =~ s/[\n\r]+/\n/gs;

        # remove whitespaces
        $text =~ s/^\n+//gs;
        $text =~ s/[\s\n]+$//gs;

        if ($text eq "") {
                $text="#-#quote##forwarded message##quote#-#";
        }

        # cut to 5 lines;
        if ($text =~ s,^((?:.*?[\n\r]){5}).*$,$1,s) {
                $text =~ s/[\n\r]*$/ .../;
        }

#       my $context = Text::Context::EitherSide->new($text, context => 5);
#       return $context->as_string("perl");

        return html_escape($text);
}

sub body_filter {
        my $text = shift;

        my $sig = '';

        # remove signature
        if ($text =~ s/([\n\r]+)(--\s*[\n\r]+.*)$//s) {
                $sig = "$1#-#signature##$2##signature#-#";
        }

        # find quoted text
        $text =~ s/^([\>:\|=]+[^\n\r]*[\n\r]*)$/#-#quote1##$1##quote1#-#/mg;
        $text =~ s/(--+\s*Original\s+Message\s*--+.*)$/#-#quote2##$1##quote2#-#/si;
        $text =~ s/(--+\s*Forwarded\s+message.+\s*--+.*)$/#-#quote3##$1##quote3#-#/si;

        $text = html_escape($text . $sig);
        return $text;
}

1	dpavlin	5	#!/usr/bin/perl
2
3			# based on post
4			# http://www.mail-archive.com/libwww@perl.org/msg04750.html
5
6	dpavlin	43	BEGIN {
7			my $basedir = readlink($0) \|\| $0; $basedir =~ s#/[^/]+$##;
8			unshift(@INC, $basedir);
9			}
10
11	dpavlin	5	use strict;
12			use warnings;
13	dpavlin	41	use MWS::SWISH;
14			#use MWS::Plucene;
15	dpavlin	5	use HTTP::Daemon;
16			use HTTP::Status;
17			use IO::String;
18	dpavlin	6	use CGI::Lite;
19			use Template;
20	dpavlin	24	use URI::Escape;
21	dpavlin	5
22	dpavlin	6	use Data::Dumper;
23
24	dpavlin	17	my $debug = 1;
25
26	dpavlin	27	my $config_file = shift @ARGV \|\| 'global.conf';
27
28			if (! -f $config_file) {
29			print qq{Usage: $0 [/path/to/local.conf]
30
31			If local.conf is not specified, global.conf in current directory will
32			be used.
33			};
34			exit 1;
35			}
36
37	dpavlin	41	my $mws = MWS::SWISH->new(config_file => $config_file);
38			#my $mws = MWS::Plucene->new(config_file => $config_file, debug => $debug);
39	dpavlin	39
40			my ($local_addr,$local_port) = ('127.0.0.1',6969);
41
42			my $listen = $mws->{config}->val('global', 'listen');
43	dpavlin	41
44			print STDERR "using listen $listen\n" if ($listen);
45
46			if ($listen && $listen =~ m/:/) {
47			($local_addr,$local_port) = split(/:/,$listen,2);
48	dpavlin	39	} elsif ($listen) {
49			$local_addr = $listen;
50			}
51
52			my $d = HTTP::Daemon->new(
53			Reuse => 1,
54			LocalAddr => $local_addr,
55			LocalPort => $local_port,
56	dpavlin	41	) \|\| die "can't create HTTP::Daemon on $local_addr:$local_port: $!";
57	dpavlin	39
58	dpavlin	6	my $cgi = new CGI::Lite;
59			my $tt = Template->new({
60			INCLUDE_PATH => $mws->{config}->val('global', 'templates'),
61			FILTERS => {
62			'body5' => \&body5_filter,
63	dpavlin	28	'body' => \&body_filter,
64	dpavlin	6	},
65	dpavlin	20	EVAL_PERL => 1,
66	dpavlin	6	});
67
68	dpavlin	25	my $static_html = $mws->{config}->val('global', 'static_html');
69
70	dpavlin	13	print "Web server ready at: ", $d->url, "\n";
71	dpavlin	6
72	dpavlin	13
73	dpavlin	5	while ( my $c = $d->accept ) {
74			while ( my $r = $c->get_request ) {
75
76			# environs that a webserver should set.
77			$ENV{'REQUEST_METHOD'} = $r->method;
78			$ENV{'GATEWAY_INTERFACE'} = "CGI/1.0";
79			$ENV{'SERVER_PROTOCOL'} = $r->protocol;
80			$ENV{'CONTENT_TYPE'} = $r->content_type;
81
82	dpavlin	6	# this part is based on CGI::Lite
83	dpavlin	5
84	dpavlin	6	$cgi->close_all_files();
85			$cgi->{web_data} = {};
86			$cgi->{ordered_keys} = [];
87			$cgi->{all_handles} = [];
88			$cgi->{error_status} = 0;
89			$cgi->{error_message} = undef;
90
91	dpavlin	5	if ( $r->method eq 'GET' \|\| $r->uri =~ /\?/ ) {
92	dpavlin	6	my $query_string = $r->uri;
93			$query_string =~ s/[^\?]+\?(.*)/$1/;
94			$cgi->_decode_url_encoded_data (\$query_string, 'form');
95
96			} elsif ( $r->method eq 'POST' ) {
97
98			if ($r->content_type eq 'application/x-www-form-urlencoded') {
99			# local $^W = 0;
100			$cgi->_decode_url_encoded_data (\$r->content, 'form');
101			} elsif ($r->content_type =~ /multipart\/form-data/) {
102			my ($boundary) = $r->content_type =~ /boundary=(\S+)$/;
103			$cgi->_parse_multipart_data ($r->content_length, $boundary);
104			}
105			} else {
106			$c->send_error(RC_FORBIDDEN);
107	dpavlin	5	}
108
109	dpavlin	6	my $param = $cgi->{web_data};
110			my $url = $r->url->path;
111	dpavlin	5
112	dpavlin	6	# XXX LOG
113	dpavlin	30	print $r->method," ",$url,"\n";
114	dpavlin	42	print Dumper($param,$mws->{counter}),"\n" if ($debug);
115	dpavlin	5
116	dpavlin	25	# is this static page?
117			if ($static_html && -f "$static_html/$url") {
118			print "static file: $static_html/$url\n" if ($debug);
119			$c->send_file_response("$static_html/$url");
120			$c->close;
121			next;
122			}
123
124	dpavlin	7	# template file name (use ?format=html as default)
125			my $tpl_file = 'master.';
126			$tpl_file .= $param->{'format'} \|\| 'html';
127
128	dpavlin	20	# parse date from url
129			my ($yyyy,$mm,$dd) = $mws->yyyymmdd;
130
131			my $yyyymm;
132
133			my $date_limit;
134
135			if ($url =~ m,^/(\d{4})[/-](\d+)[/-](\d+),) {
136			($yyyy, $mm, $dd) = $mws->fmtdate($1,$2,$3);
137			$date_limit = "$yyyy-$mm-$dd";
138			} elsif ($url =~ m,^/(\d{4})[/-](\d+),) {
139			($yyyy,$mm) = $mws->fmtdate($1,$2);
140			$date_limit = "$yyyy-$mm";
141			} elsif ($url =~ m,^/(\d{4}),) {
142			$date_limit = $mws->fmtdate($1);
143			}
144
145	dpavlin	7	#
146			# implement functionality and generate HTML
147			#
148	dpavlin	6	my $html;
149	dpavlin	5
150	dpavlin	12	if ($param->{'search_val'} && $param->{'search_fld'} && !$param->{'search'}) {
151			$param->{'search'} = $param->{'search_fld'}.":".$param->{'search_val'};
152	dpavlin	16	} elsif ($param->{'search'}) {
153			($param->{'search_fld'}, $param->{'search_val'}) = split(/:/,$param->{'search'},2);
154	dpavlin	12	}
155
156	dpavlin	13	my $tpl_var = {
157	dpavlin	20	param => $param,
158			yyyy => $yyyy,
159			mm => $mm,
160			dd => $dd,
161	dpavlin	21	date_limit => $date_limit,
162	dpavlin	13	};
163
164	dpavlin	27	# is this access to root of web server?
165			if ($url eq "/" && !$param->{'search'}) {
166			# if first access, go to current year
167			$date_limit = $mws->fmtdate($yyyy);
168	dpavlin	28	$param->{sort_by} = "date desc";
169	dpavlin	27	}
170
171	dpavlin	21	# ?show_id=XXXXxxxx___message_id___xxxxXXXX
172			if ($param->{'show_id'}) {
173	dpavlin	20
174	dpavlin	21	$mws->reset_counters;
175			my $row = $mws->fetch_result_by_id($param->{'show_id'});
176			$tpl_var->{message} = $row;
177			} elsif ($param->{'search'} \|\| $date_limit) {
178	dpavlin	5
179	dpavlin	21	# show search results
180			# ?search=foo:bar
181	dpavlin	5
182	dpavlin	27	my @search;
183			push @search, $param->{'search'} if ($param->{'search'});
184	dpavlin	21
185			if ($date_limit) {
186			push @search, "and" if (@search);
187			push @search, "date:\"$date_limit\"";
188			}
189
190	dpavlin	24	if ($param->{sort_by}) {
191			push @search, "sort:".$param->{sort_by};
192			}
193
194	dpavlin	21	print STDERR "search: ",join(" ",@search),"\n";
195
196			my $results = $mws->search(@search);
197	dpavlin	6	my @res = $mws->fetch_all_results();
198	dpavlin	5
199	dpavlin	20	$tpl_var->{results} = \@res if (@res);
200	dpavlin	25	$tpl_var->{total_hits} = $mws->{total_hits} \|\| 0;
201	dpavlin	7
202	dpavlin	30	# no hits, offer suggestions
203			if (! $tpl_var->{results}) {
204			@{$tpl_var->{apropos}} = $mws->apropos_index($param->{'search_fld'}, $param->{'search_val'});
205			}
206
207	dpavlin	6	}
208	dpavlin	5
209	dpavlin	19
210			# push counters to template
211	dpavlin	42	foreach my $f (qw(from to cc bcc folder)) {
212	dpavlin	19	my $h = $mws->counter($f) \|\| next;
213			my @a;
214			foreach my $k (sort { $h->{$b}->{usage} <=> $h->{$a}->{usage} } keys %$h) {
215			push @a, $h->{$k};
216			}
217			$tpl_var->{counters}->{$f} = [ @a ] if (@a);
218			}
219
220	dpavlin	20	# push calendar in template
221			$tpl_var->{calendar} = $mws->counter('calendar');
222
223	dpavlin	13	$tt->process($tpl_file, $tpl_var, \$html) \|\| die $tt->error();
224
225	dpavlin	7	#
226			# send HTMLto client
227			#
228
229	dpavlin	5	my $res = HTTP::Response->new(RC_OK);
230	dpavlin	14	$res->header( 'Content-type' => 'text/html; charset=ISO-8859-2' );
231	dpavlin	6	$res->content($html);
232	dpavlin	5	$c->send_response($res);
233
234			$c->close;
235			}
236			undef($c);
237			}
238	dpavlin	6
239			# template toolkit filter
240
241	dpavlin	28	sub html_escape($) {
242	dpavlin	30	my $text = shift \|\| return;
243	dpavlin	28
244	dpavlin	30	# don't re-escape html
245	dpavlin	37	#return $text if ($text =~ /&(?:lt\|gt\|amp\|quot);/);
246	dpavlin	30
247	dpavlin	28	# Escape <, >, & and ", and to produce valid XML
248			my %escape = ('<'=>'<', '>'=>'>', '&'=>'&', '"'=>'"');
249			my $escape_re = join '\|' => keys %escape;
250
251			$text =~ s/($escape_re)/$escape{$1}/gs;
252	dpavlin	34
253			while ($text =~ s/#-#(quote\|signature)(\d*)##(.+?)##\1\2#-#/<span class="$1">$3<\/span>/gs) { } ;
254
255	dpavlin	28	return $text;
256			}
257
258	dpavlin	12	#use Text::Context::EitherSide;
259
260	dpavlin	6	sub body5_filter {
261			my $text = shift;
262	dpavlin	28
263			# remove quote
264	dpavlin	37	$text =~ s/^[\>:\\|=]+[^\n\r][\n\r]$/#-q-#/msg;
265	dpavlin	28	# remove quote author
266	dpavlin	37	$text =~ s/[\n\r]+[^\n\r]+:\s(?:#-q-#[\n\r])+//gs;
267			$text =~ s/^[^\n\r]+:\s(?:#-q-#[\n\r])+//gs;
268	dpavlin	30	$text =~ s/#-q-#[\n\r]*//gs;
269	dpavlin	28	# outlook quoting
270			$text =~ s/(\s--+\sOriginal\s+Message\s--+.)$//si;
271	dpavlin	34	$text =~ s/(\s--+\sForwarded\s+message.+\s--+.)$//si;
272	dpavlin	28
273			# remove signature
274			$text =~ s/[\n\r]+--\s[\n\r]+.$//s;
275
276			# compress cr/lf
277			$text =~ s/[\n\r]+/\n/gs;
278
279			# remove whitespaces
280			$text =~ s/^\n+//gs;
281			$text =~ s/[\s\n]+$//gs;
282
283	dpavlin	34	if ($text eq "") {
284			$text="#-#quote##forwarded message##quote#-#";
285			}
286
287	dpavlin	28	# cut to 5 lines;
288	dpavlin	14	if ($text =~ s,^((?:.?[\n\r]){5}).$,$1,s) {
289			$text =~ s/[\n\r]*$/ .../;
290			}
291	dpavlin	12
292			# my $context = Text::Context::EitherSide->new($text, context => 5);
293			# return $context->as_string("perl");
294
295	dpavlin	28	return html_escape($text);
296			}
297
298			sub body_filter {
299			my $text = shift;
300
301			my $sig = '';
302
303			# remove signature
304			if ($text =~ s/([\n\r]+)(--\s[\n\r]+.)$//s) {
305			$sig = "$1#-#signature##$2##signature#-#";
306			}
307
308			# find quoted text
309	dpavlin	37	$text =~ s/^([\>:\\|=]+[^\n\r][\n\r])$/#-#quote1##$1##quote1#-#/mg;
310	dpavlin	30	$text =~ s/(--+\sOriginal\s+Message\s--+.*)$/#-#quote2##$1##quote2#-#/si;
311	dpavlin	34	$text =~ s/(--+\sForwarded\s+message.+\s--+.*)$/#-#quote3##$1##quote3#-#/si;
312	dpavlin	28
313			$text = html_escape($text . $sig);
314	dpavlin	6	return $text;
315			}
316	dpavlin	7