mws/trunk/httpd.pl

#!/usr/bin/perl

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

use strict;
use warnings;
use HTTP::Daemon;
use HTTP::Status;
use IO::String;
use CGI::Lite;
use Template;
use MWS;
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 $d = HTTP::Daemon->new( Reuse => 1, LocalPort => 6969 ) || die;
my $cgi = new CGI::Lite;
my $mws = MWS->new($config_file);
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",Dumper($param),"\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;

                }


                # push counters to template
                foreach my $f (qw(from to cc bcc)) {
                        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;

        # 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;
        return $text;
}

#use Text::Context::EitherSide;

sub body5_filter {
        my $text = shift;

        # remove quote
        $text =~ s/^[\>:\|=]+\s*.*?$/#-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;
        # outlook quoting
        $text =~ s/(\s*--+\s*Original\s+Message\s*--+.*)$//si;
        $text =~ s/(\s*--+\s*Forwarded\s+message\s*from\s+.+\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;

        # 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/^([\>:\|=]+\s*.*?)$/#-#quote##$1##quote#-#/msg;
        $text =~ s/(--+\s*Original\s+Message\s*--+.*)$/#-#quote##$1##quote#-#/si || $text =~ s/(--+\s*Forwarded\s+message\s*from\s+.+\s*--+.*)$/#-#quote##$1##quote#-#/si;

        $text = html_escape($text . $sig);
        $text =~ s/#-#(quote|signature)##(.+?)##(\1)#-#/<span class="$1">$2<\/span>/gs;
        return $text;
}

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