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 $d = HTTP::Daemon->new( Reuse => 1, LocalPort => 6969 ) || die;
my $cgi = new CGI::Lite;
my $mws = MWS->new('global.conf');
my $tt = Template->new({
        INCLUDE_PATH => $mws->{config}->val('global', 'templates'),
        FILTERS => {
                'body5' => \&body5_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,
                };

                #
                # ?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 = ( $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

#use Text::Context::EitherSide;

sub body5_filter {
        my $text = shift;
        $text =~ s/^\s+//gs;
        $text =~ s/^[\>:\|=]+\s*.*?$//msg;      # remove quoted text
        $text =~ s/[\n\r]+/\n/gs;               # compress cr/lf
        if ($text =~ s,^((?:.*?[\n\r]){5}).*$,$1,s) {
                $text =~ s/[\n\r]*$/ .../;
        }
        $text =~ s/[\n\r]+--\s*[\n\r]+.*$//s;

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

        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			use strict;
7			use warnings;
8			use HTTP::Daemon;
9			use HTTP::Status;
10			use IO::String;
11	dpavlin	6	use CGI::Lite;
12			use Template;
13			use MWS;
14	dpavlin	24	use URI::Escape;
15	dpavlin	5
16	dpavlin	6	use Data::Dumper;
17
18	dpavlin	17	my $debug = 1;
19
20	dpavlin	5	my $d = HTTP::Daemon->new( Reuse => 1, LocalPort => 6969 ) \|\| die;
21	dpavlin	6	my $cgi = new CGI::Lite;
22			my $mws = MWS->new('global.conf');
23			my $tt = Template->new({
24			INCLUDE_PATH => $mws->{config}->val('global', 'templates'),
25			FILTERS => {
26			'body5' => \&body5_filter,
27			},
28	dpavlin	20	EVAL_PERL => 1,
29	dpavlin	6	});
30
31	dpavlin	25	my $static_html = $mws->{config}->val('global', 'static_html');
32
33	dpavlin	13	print "Web server ready at: ", $d->url, "\n";
34	dpavlin	6
35	dpavlin	13
36	dpavlin	5	while ( my $c = $d->accept ) {
37			while ( my $r = $c->get_request ) {
38
39			# environs that a webserver should set.
40			$ENV{'REQUEST_METHOD'} = $r->method;
41			$ENV{'GATEWAY_INTERFACE'} = "CGI/1.0";
42			$ENV{'SERVER_PROTOCOL'} = $r->protocol;
43			$ENV{'CONTENT_TYPE'} = $r->content_type;
44
45	dpavlin	6	# this part is based on CGI::Lite
46	dpavlin	5
47	dpavlin	6	$cgi->close_all_files();
48			$cgi->{web_data} = {};
49			$cgi->{ordered_keys} = [];
50			$cgi->{all_handles} = [];
51			$cgi->{error_status} = 0;
52			$cgi->{error_message} = undef;
53
54	dpavlin	5	if ( $r->method eq 'GET' \|\| $r->uri =~ /\?/ ) {
55	dpavlin	6	my $query_string = $r->uri;
56			$query_string =~ s/[^\?]+\?(.*)/$1/;
57			$cgi->_decode_url_encoded_data (\$query_string, 'form');
58
59			} elsif ( $r->method eq 'POST' ) {
60
61			if ($r->content_type eq 'application/x-www-form-urlencoded') {
62			# local $^W = 0;
63			$cgi->_decode_url_encoded_data (\$r->content, 'form');
64			} elsif ($r->content_type =~ /multipart\/form-data/) {
65			my ($boundary) = $r->content_type =~ /boundary=(\S+)$/;
66			$cgi->_parse_multipart_data ($r->content_length, $boundary);
67			}
68			} else {
69			$c->send_error(RC_FORBIDDEN);
70	dpavlin	5	}
71
72	dpavlin	6	my $param = $cgi->{web_data};
73			my $url = $r->url->path;
74	dpavlin	5
75	dpavlin	6	# XXX LOG
76	dpavlin	17	print $r->method," ",$url,"\n",Dumper($param),"\n" if ($debug);
77	dpavlin	5
78	dpavlin	25	# is this static page?
79			if ($static_html && -f "$static_html/$url") {
80			print "static file: $static_html/$url\n" if ($debug);
81			$c->send_file_response("$static_html/$url");
82			$c->close;
83			next;
84			}
85
86	dpavlin	7	# template file name (use ?format=html as default)
87			my $tpl_file = 'master.';
88			$tpl_file .= $param->{'format'} \|\| 'html';
89
90	dpavlin	20	# parse date from url
91			my ($yyyy,$mm,$dd) = $mws->yyyymmdd;
92
93			my $yyyymm;
94
95			my $date_limit;
96
97			if ($url =~ m,^/(\d{4})[/-](\d+)[/-](\d+),) {
98			($yyyy, $mm, $dd) = $mws->fmtdate($1,$2,$3);
99			$date_limit = "$yyyy-$mm-$dd";
100			} elsif ($url =~ m,^/(\d{4})[/-](\d+),) {
101			($yyyy,$mm) = $mws->fmtdate($1,$2);
102			$date_limit = "$yyyy-$mm";
103			} elsif ($url =~ m,^/(\d{4}),) {
104			$date_limit = $mws->fmtdate($1);
105			}
106
107	dpavlin	7	#
108			# implement functionality and generate HTML
109			#
110	dpavlin	6	my $html;
111	dpavlin	5
112	dpavlin	12	if ($param->{'search_val'} && $param->{'search_fld'} && !$param->{'search'}) {
113			$param->{'search'} = $param->{'search_fld'}.":".$param->{'search_val'};
114	dpavlin	16	} elsif ($param->{'search'}) {
115			($param->{'search_fld'}, $param->{'search_val'}) = split(/:/,$param->{'search'},2);
116	dpavlin	12	}
117
118	dpavlin	13	my $tpl_var = {
119	dpavlin	20	param => $param,
120			yyyy => $yyyy,
121			mm => $mm,
122			dd => $dd,
123	dpavlin	21	date_limit => $date_limit,
124	dpavlin	13	};
125
126	dpavlin	21	#
127			# ?show_id=XXXXxxxx___message_id___xxxxXXXX
128			if ($param->{'show_id'}) {
129	dpavlin	20
130	dpavlin	21	$mws->reset_counters;
131			my $row = $mws->fetch_result_by_id($param->{'show_id'});
132			$tpl_var->{message} = $row;
133			} elsif ($param->{'search'} \|\| $date_limit) {
134	dpavlin	5
135	dpavlin	21	# show search results
136			# ?search=foo:bar
137	dpavlin	5
138	dpavlin	21	my @search = ( $param->{'search'} );
139
140			if ($date_limit) {
141			push @search, "and" if (@search);
142			push @search, "date:\"$date_limit\"";
143			}
144
145	dpavlin	24	if ($param->{sort_by}) {
146			push @search, "sort:".$param->{sort_by};
147			}
148
149	dpavlin	21	print STDERR "search: ",join(" ",@search),"\n";
150
151			my $results = $mws->search(@search);
152	dpavlin	6	my @res = $mws->fetch_all_results();
153	dpavlin	5
154	dpavlin	20	$tpl_var->{results} = \@res if (@res);
155	dpavlin	25	$tpl_var->{total_hits} = $mws->{total_hits} \|\| 0;
156	dpavlin	7
157	dpavlin	6	}
158	dpavlin	5
159	dpavlin	19
160			# push counters to template
161			foreach my $f (qw(from to cc bcc)) {
162			my $h = $mws->counter($f) \|\| next;
163			my @a;
164			foreach my $k (sort { $h->{$b}->{usage} <=> $h->{$a}->{usage} } keys %$h) {
165			push @a, $h->{$k};
166			}
167			$tpl_var->{counters}->{$f} = [ @a ] if (@a);
168			}
169
170	dpavlin	20	# push calendar in template
171			$tpl_var->{calendar} = $mws->counter('calendar');
172
173	dpavlin	13	$tt->process($tpl_file, $tpl_var, \$html) \|\| die $tt->error();
174
175	dpavlin	7	#
176			# send HTMLto client
177			#
178
179	dpavlin	5	my $res = HTTP::Response->new(RC_OK);
180	dpavlin	14	$res->header( 'Content-type' => 'text/html; charset=ISO-8859-2' );
181	dpavlin	6	$res->content($html);
182	dpavlin	5	$c->send_response($res);
183
184			$c->close;
185			}
186			undef($c);
187			}
188	dpavlin	6
189			# template toolkit filter
190
191	dpavlin	12	#use Text::Context::EitherSide;
192
193	dpavlin	6	sub body5_filter {
194			my $text = shift;
195			$text =~ s/^\s+//gs;
196	dpavlin	12	$text =~ s/^[\>:\\|=]+\s.?$//msg; # remove quoted text
197			$text =~ s/[\n\r]+/\n/gs; # compress cr/lf
198	dpavlin	14	if ($text =~ s,^((?:.?[\n\r]){5}).$,$1,s) {
199			$text =~ s/[\n\r]*$/ .../;
200			}
201	dpavlin	7	$text =~ s/[\n\r]+--\s[\n\r]+.$//s;
202	dpavlin	12
203			# my $context = Text::Context::EitherSide->new($text, context => 5);
204			# return $context->as_string("perl");
205
206	dpavlin	6	return $text;
207			}
208	dpavlin	7