mws/trunk/httpd.pl

#!/usr/bin/perl

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