mws/trunk/httpd.pl

#!/usr/bin/perl

my $basedir = '';
BEGIN {
        $basedir = $0;
        my $loop = 0;   # to prevent symlink loops
        while (-l $basedir && $loop++ < 20) {
                $basedir = readlink($basedir);
        }
        $basedir =~ s#/+[^/]+$#/lib#;
}
if ($basedir) {
        use lib "$basedir";
}

=head1 NAME

httpd.pl - http server for Mail::Box Web Search

=head1 SYNOPSYS

 httpd.pl [local.conf]

=head1 DESCRIPTION

This script implements user interface for Mail::Box Web Search as
a small single-user http server.

=head1 SEE ALSO

C<MWS> perl modules which are part of this package
C<MWS::HTTPD> module which implements the server itself

=cut

use strict;
use warnings;
use MWS::SWISH;
#use MWS::Plucene;
use HTTP::Daemon::Simple;
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 $tt = Template->new({
        INCLUDE_PATH => $mws->{config}->val('global', 'templates'),
        FILTERS => {
                'body5' => \&body5_filter,
                'body' => \&body_filter,
        },
        EVAL_PERL => 1,
});

my $d = new HTTP::Daemon::Simple(
        'listen' => $mws->{config}->val('global', 'listen'),
        'static_html' => $mws->{config}->val('global', 'static_html'),
        'debug' => $debug,
) || die "can't create HTTP::Daemon::Simple: $!";


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

$d->run_server( \&request );

sub request($$) {
        my ($url,$param) = @_;

        print Dumper($param,$mws->{counter}),"\n" if ($debug);

        # 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} && $param->{'search_fld'} && $param->{'search_val'}) {
                        @{$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();
        return $html;
};

# 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;
        $text =~ s/(?:^|[\n\r]+)*_____+[\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#-#";
        } elsif ($text =~s/(^|[\n\r]+)*(_____+[\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	dpavlin	53	my $basedir = '';
4	dpavlin	43	BEGIN {
5	dpavlin	53	$basedir = $0;
6			my $loop = 0; # to prevent symlink loops
7			while (-l $basedir && $loop++ < 20) {
8			$basedir = readlink($basedir);
9			}
10			$basedir =~ s#/+[^/]+$#/lib#;
11	dpavlin	43	}
12	dpavlin	53	if ($basedir) {
13			use lib "$basedir";
14			}
15	dpavlin	43
16	dpavlin	47	=head1 NAME
17
18			httpd.pl - http server for Mail::Box Web Search
19
20			=head1 SYNOPSYS
21
22			httpd.pl [local.conf]
23
24			=head1 DESCRIPTION
25
26	dpavlin	52	This script implements user interface for Mail::Box Web Search as
27			a small single-user http server.
28	dpavlin	47
29			=head1 SEE ALSO
30
31			C<MWS> perl modules which are part of this package
32	dpavlin	52	C<MWS::HTTPD> module which implements the server itself
33	dpavlin	47
34			=cut
35
36	dpavlin	5	use strict;
37			use warnings;
38	dpavlin	41	use MWS::SWISH;
39			#use MWS::Plucene;
40	dpavlin	52	use HTTP::Daemon::Simple;
41	dpavlin	6	use Template;
42	dpavlin	24	use URI::Escape;
43	dpavlin	5
44	dpavlin	6	use Data::Dumper;
45
46	dpavlin	17	my $debug = 1;
47
48	dpavlin	27	my $config_file = shift @ARGV \|\| 'global.conf';
49
50			if (! -f $config_file) {
51			print qq{Usage: $0 [/path/to/local.conf]
52
53			If local.conf is not specified, global.conf in current directory will
54			be used.
55			};
56			exit 1;
57			}
58
59	dpavlin	41	my $mws = MWS::SWISH->new(config_file => $config_file);
60			#my $mws = MWS::Plucene->new(config_file => $config_file, debug => $debug);
61	dpavlin	39
62	dpavlin	6	my $tt = Template->new({
63			INCLUDE_PATH => $mws->{config}->val('global', 'templates'),
64			FILTERS => {
65			'body5' => \&body5_filter,
66	dpavlin	28	'body' => \&body_filter,
67	dpavlin	6	},
68	dpavlin	20	EVAL_PERL => 1,
69	dpavlin	6	});
70
71	dpavlin	52	my $d = new HTTP::Daemon::Simple(
72			'listen' => $mws->{config}->val('global', 'listen'),
73			'static_html' => $mws->{config}->val('global', 'static_html'),
74			'debug' => $debug,
75			) \|\| die "can't create HTTP::Daemon::Simple: $!";
76	dpavlin	25
77	dpavlin	52
78	dpavlin	13	print "Web server ready at: ", $d->url, "\n";
79	dpavlin	6
80	dpavlin	52	$d->run_server( \&request );
81	dpavlin	13
82	dpavlin	52	sub request($$) {
83			my ($url,$param) = @_;
84	dpavlin	5
85	dpavlin	52	print Dumper($param,$mws->{counter}),"\n" if ($debug);
86	dpavlin	5
87	dpavlin	52	# template file name (use ?format=html as default)
88			my $tpl_file = 'master.';
89			$tpl_file .= $param->{'format'} \|\| 'html';
90	dpavlin	5
91	dpavlin	52	# parse date from url
92			my ($yyyy,$mm,$dd) = $mws->yyyymmdd;
93	dpavlin	6
94	dpavlin	52	my $yyyymm;
95	dpavlin	6
96	dpavlin	52	my $date_limit;
97	dpavlin	6
98	dpavlin	52	if ($url =~ m,^/(\d{4})[/-](\d+)[/-](\d+),) {
99			($yyyy, $mm, $dd) = $mws->fmtdate($1,$2,$3);
100			$date_limit = "$yyyy-$mm-$dd";
101			} elsif ($url =~ m,^/(\d{4})[/-](\d+),) {
102			($yyyy,$mm) = $mws->fmtdate($1,$2);
103			$date_limit = "$yyyy-$mm";
104			} elsif ($url =~ m,^/(\d{4}),) {
105			$date_limit = $mws->fmtdate($1);
106			}
107	dpavlin	5
108	dpavlin	52	#
109			# implement functionality and generate HTML
110			#
111			my $html;
112	dpavlin	5
113	dpavlin	52	if ($param->{'search_val'} && $param->{'search_fld'} && !$param->{'search'}) {
114			$param->{'search'} = $param->{'search_fld'}.":".$param->{'search_val'};
115			} elsif ($param->{'search'}) {
116			($param->{'search_fld'}, $param->{'search_val'}) = split(/:/,$param->{'search'},2);
117			}
118	dpavlin	5
119	dpavlin	52	my $tpl_var = {
120			param => $param,
121			yyyy => $yyyy,
122			mm => $mm,
123			dd => $dd,
124			date_limit => $date_limit,
125			};
126	dpavlin	25
127	dpavlin	52	# is this access to root of web server?
128			if ($url eq "/" && !$param->{'search'}) {
129			# if first access, go to current year
130			$date_limit = $mws->fmtdate($yyyy);
131			$param->{sort_by} = "date desc";
132			}
133	dpavlin	7
134	dpavlin	52	# ?show_id=XXXXxxxx___message_id___xxxxXXXX
135			if ($param->{'show_id'}) {
136	dpavlin	20
137	dpavlin	52	$mws->reset_counters;
138			my $row = $mws->fetch_result_by_id($param->{'show_id'});
139			$tpl_var->{message} = $row;
140			} elsif ($param->{'search'} \|\| $date_limit) {
141	dpavlin	20
142	dpavlin	52	# show search results
143			# ?search=foo:bar
144	dpavlin	20
145	dpavlin	52	my @search;
146			push @search, $param->{'search'} if ($param->{'search'});
147	dpavlin	20
148	dpavlin	52	if ($date_limit) {
149			push @search, "and" if (@search);
150			push @search, "date:\"$date_limit\"";
151	dpavlin	12	}
152
153	dpavlin	52	if ($param->{sort_by}) {
154			push @search, "sort:".$param->{sort_by};
155	dpavlin	27	}
156
157	dpavlin	52	print STDERR "search: ",join(" ",@search),"\n";
158	dpavlin	20
159	dpavlin	52	my $results = $mws->search(@search);
160			my @res = $mws->fetch_all_results();
161	dpavlin	5
162	dpavlin	52	$tpl_var->{results} = \@res if (@res);
163			$tpl_var->{total_hits} = $mws->{total_hits} \|\| 0;
164	dpavlin	5
165	dpavlin	52	# no hits, offer suggestions
166	dpavlin	53	if (! $tpl_var->{results} && $param->{'search_fld'} && $param->{'search_val'}) {
167	dpavlin	52	@{$tpl_var->{apropos}} = $mws->apropos_index($param->{'search_fld'}, $param->{'search_val'});
168	dpavlin	6	}
169	dpavlin	5
170	dpavlin	52	}
171	dpavlin	19
172	dpavlin	52	# push counters to template
173			foreach my $f (qw(from to cc bcc folder)) {
174			my $h = $mws->counter($f) \|\| next;
175			my @a;
176			foreach my $k (sort { $h->{$b}->{usage} <=> $h->{$a}->{usage} } keys %$h) {
177			push @a, $h->{$k};
178	dpavlin	19	}
179	dpavlin	52	$tpl_var->{counters}->{$f} = [ @a ] if (@a);
180			}
181	dpavlin	19
182	dpavlin	52	# push calendar in template
183			$tpl_var->{calendar} = $mws->counter('calendar');
184	dpavlin	20
185	dpavlin	52	$tt->process($tpl_file, $tpl_var, \$html) \|\| die $tt->error();
186			return $html;
187			};
188	dpavlin	13
189	dpavlin	6	# template toolkit filter
190
191	dpavlin	28	sub html_escape($) {
192	dpavlin	30	my $text = shift \|\| return;
193	dpavlin	28
194	dpavlin	30	# don't re-escape html
195	dpavlin	37	#return $text if ($text =~ /&(?:lt\|gt\|amp\|quot);/);
196	dpavlin	30
197	dpavlin	28	# Escape <, >, & and ", and to produce valid XML
198			my %escape = ('<'=>'<', '>'=>'>', '&'=>'&', '"'=>'"');
199			my $escape_re = join '\|' => keys %escape;
200
201			$text =~ s/($escape_re)/$escape{$1}/gs;
202	dpavlin	34
203			while ($text =~ s/#-#(quote\|signature)(\d*)##(.+?)##\1\2#-#/<span class="$1">$3<\/span>/gs) { } ;
204
205	dpavlin	28	return $text;
206			}
207
208	dpavlin	12	#use Text::Context::EitherSide;
209
210	dpavlin	6	sub body5_filter {
211			my $text = shift;
212	dpavlin	28
213			# remove quote
214	dpavlin	37	$text =~ s/^[\>:\\|=]+[^\n\r][\n\r]$/#-q-#/msg;
215	dpavlin	28	# remove quote author
216	dpavlin	37	$text =~ s/[\n\r]+[^\n\r]+:\s(?:#-q-#[\n\r])+//gs;
217			$text =~ s/^[^\n\r]+:\s(?:#-q-#[\n\r])+//gs;
218	dpavlin	30	$text =~ s/#-q-#[\n\r]*//gs;
219	dpavlin	28	# outlook quoting
220			$text =~ s/(\s--+\sOriginal\s+Message\s--+.)$//si;
221	dpavlin	34	$text =~ s/(\s--+\sForwarded\s+message.+\s--+.)$//si;
222	dpavlin	28
223			# remove signature
224	dpavlin	44	$text =~ s/(?:^\|[\n\r]+)--\s[\n\r]+.*$//s;
225			$text =~ s/(?:^\|[\n\r]+)_____+[\n\r]+.$//s;
226	dpavlin	28
227			# compress cr/lf
228			$text =~ s/[\n\r]+/\n/gs;
229
230			# remove whitespaces
231			$text =~ s/^\n+//gs;
232			$text =~ s/[\s\n]+$//gs;
233
234	dpavlin	34	if ($text eq "") {
235			$text="#-#quote##forwarded message##quote#-#";
236			}
237
238	dpavlin	28	# cut to 5 lines;
239	dpavlin	14	if ($text =~ s,^((?:.?[\n\r]){5}).$,$1,s) {
240			$text =~ s/[\n\r]*$/ .../;
241			}
242	dpavlin	12
243			# my $context = Text::Context::EitherSide->new($text, context => 5);
244			# return $context->as_string("perl");
245
246	dpavlin	28	return html_escape($text);
247			}
248
249			sub body_filter {
250			my $text = shift;
251
252			my $sig = '';
253
254			# remove signature
255			if ($text =~ s/([\n\r]+)(--\s[\n\r]+.)$//s) {
256			$sig = "$1#-#signature##$2##signature#-#";
257	dpavlin	44	} elsif ($text =~s/(^\|[\n\r]+)(_____+[\n\r]+.)$//s) {
258			$sig = "$1#-#signature##$2##signature#-#";
259	dpavlin	28	}
260
261			# find quoted text
262	dpavlin	37	$text =~ s/^([\>:\\|=]+[^\n\r][\n\r])$/#-#quote1##$1##quote1#-#/mg;
263	dpavlin	30	$text =~ s/(--+\sOriginal\s+Message\s--+.*)$/#-#quote2##$1##quote2#-#/si;
264	dpavlin	34	$text =~ s/(--+\sForwarded\s+message.+\s--+.*)$/#-#quote3##$1##quote3#-#/si;
265	dpavlin	28
266			$text = html_escape($text . $sig);
267	dpavlin	6	return $text;
268			}
269	dpavlin	7