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 Data::Dumper;

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,
                'subject_search' => \&subject_search_filter,
        },
});

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,Dumper($param);

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

                #
                # 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
                };

                # show search results
                # ?search=foo:bar
                if ($param->{'search'}) {

                        print STDERR "search: ",$param->{'search'},"\n";

                        my $results = $mws->search($param->{'search'});
                        my @res = $mws->fetch_all_results();

                        $tpl_var->{results} = \@res;


                #
                # ?show_id=XXXXxxxx___message_id___xxxxXXXX
                } elsif ($param->{'show_id'}) {
                        
                        my $row = $mws->fetch_result_by_id($param->{'show_id'});
                        $tpl_var->{message} = $row;
                }

                $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;
}

sub subject_search_filter {
        my $s = shift;
        # remove re: fdw: [list] preffixes from e-mail
        while ( $s =~ s/^\s*\[(?:re|fwd|fw):\s+(.+)\]\s*$/$1/ig ||
                $s =~ s/^\s*(?:re|fwd|fw):\s+(.+?)\s*$/$1/ig ||
                $s =~ s/^\[\S+\]\s*//ig ||
                $s =~ s/^\[[^@]+@\w+\.\w+\s*:\s+(.+)\s*\]\s*$/$1/g
        ) { };
        return $s;
}
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	5
15	dpavlin	6	use Data::Dumper;
16
17	dpavlin	5	my $d = HTTP::Daemon->new( Reuse => 1, LocalPort => 6969 ) \|\| die;
18	dpavlin	6	my $cgi = new CGI::Lite;
19			my $mws = MWS->new('global.conf');
20			my $tt = Template->new({
21			INCLUDE_PATH => $mws->{config}->val('global', 'templates'),
22			FILTERS => {
23			'body5' => \&body5_filter,
24	dpavlin	14	'subject_search' => \&subject_search_filter,
25	dpavlin	6	},
26			});
27
28	dpavlin	13	print "Web server ready at: ", $d->url, "\n";
29	dpavlin	6
30	dpavlin	13
31	dpavlin	5	while ( my $c = $d->accept ) {
32			while ( my $r = $c->get_request ) {
33
34			# environs that a webserver should set.
35			$ENV{'REQUEST_METHOD'} = $r->method;
36			$ENV{'GATEWAY_INTERFACE'} = "CGI/1.0";
37			$ENV{'SERVER_PROTOCOL'} = $r->protocol;
38			$ENV{'CONTENT_TYPE'} = $r->content_type;
39
40	dpavlin	6	# this part is based on CGI::Lite
41	dpavlin	5
42	dpavlin	6	$cgi->close_all_files();
43			$cgi->{web_data} = {};
44			$cgi->{ordered_keys} = [];
45			$cgi->{all_handles} = [];
46			$cgi->{error_status} = 0;
47			$cgi->{error_message} = undef;
48
49	dpavlin	5	if ( $r->method eq 'GET' \|\| $r->uri =~ /\?/ ) {
50	dpavlin	6	my $query_string = $r->uri;
51			$query_string =~ s/[^\?]+\?(.*)/$1/;
52			$cgi->_decode_url_encoded_data (\$query_string, 'form');
53
54			} elsif ( $r->method eq 'POST' ) {
55
56			if ($r->content_type eq 'application/x-www-form-urlencoded') {
57			# local $^W = 0;
58			$cgi->_decode_url_encoded_data (\$r->content, 'form');
59			} elsif ($r->content_type =~ /multipart\/form-data/) {
60			my ($boundary) = $r->content_type =~ /boundary=(\S+)$/;
61			$cgi->_parse_multipart_data ($r->content_length, $boundary);
62			}
63			} else {
64			$c->send_error(RC_FORBIDDEN);
65	dpavlin	5	}
66
67	dpavlin	6	my $param = $cgi->{web_data};
68			my $url = $r->url->path;
69	dpavlin	5
70	dpavlin	6	# XXX LOG
71			print $r->method," ",$url,Dumper($param);
72	dpavlin	5
73	dpavlin	7	# template file name (use ?format=html as default)
74			my $tpl_file = 'master.';
75			$tpl_file .= $param->{'format'} \|\| 'html';
76
77			#
78			# implement functionality and generate HTML
79			#
80	dpavlin	6	my $html;
81	dpavlin	5
82	dpavlin	12	if ($param->{'search_val'} && $param->{'search_fld'} && !$param->{'search'}) {
83			$param->{'search'} = $param->{'search_fld'}.":".$param->{'search_val'};
84	dpavlin	16	} elsif ($param->{'search'}) {
85			($param->{'search_fld'}, $param->{'search_val'}) = split(/:/,$param->{'search'},2);
86	dpavlin	12	}
87
88	dpavlin	13	my $tpl_var = {
89			param => $param
90			};
91
92	dpavlin	7	# show search results
93			# ?search=foo:bar
94			if ($param->{'search'}) {
95	dpavlin	5
96	dpavlin	7	print STDERR "search: ",$param->{'search'},"\n";
97	dpavlin	5
98	dpavlin	7	my $results = $mws->search($param->{'search'});
99	dpavlin	6	my @res = $mws->fetch_all_results();
100	dpavlin	5
101	dpavlin	13	$tpl_var->{results} = \@res;
102	dpavlin	7
103	dpavlin	13
104	dpavlin	7	#
105			# ?show_id=XXXXxxxx___message_id___xxxxXXXX
106			} elsif ($param->{'show_id'}) {
107
108			my $row = $mws->fetch_result_by_id($param->{'show_id'});
109	dpavlin	13	$tpl_var->{message} = $row;
110	dpavlin	6	}
111	dpavlin	5
112	dpavlin	13	$tt->process($tpl_file, $tpl_var, \$html) \|\| die $tt->error();
113
114	dpavlin	7	#
115			# send HTMLto client
116			#
117
118	dpavlin	5	my $res = HTTP::Response->new(RC_OK);
119	dpavlin	14	$res->header( 'Content-type' => 'text/html; charset=ISO-8859-2' );
120	dpavlin	6	$res->content($html);
121	dpavlin	5	$c->send_response($res);
122
123			$c->close;
124			}
125			undef($c);
126			}
127	dpavlin	6
128			# template toolkit filter
129
130	dpavlin	12	#use Text::Context::EitherSide;
131
132	dpavlin	6	sub body5_filter {
133			my $text = shift;
134			$text =~ s/^\s+//gs;
135	dpavlin	12	$text =~ s/^[\>:\\|=]+\s.?$//msg; # remove quoted text
136			$text =~ s/[\n\r]+/\n/gs; # compress cr/lf
137	dpavlin	14	if ($text =~ s,^((?:.?[\n\r]){5}).$,$1,s) {
138			$text =~ s/[\n\r]*$/ .../;
139			}
140	dpavlin	7	$text =~ s/[\n\r]+--\s[\n\r]+.$//s;
141	dpavlin	12
142			# my $context = Text::Context::EitherSide->new($text, context => 5);
143			# return $context->as_string("perl");
144
145	dpavlin	6	return $text;
146			}
147	dpavlin	7
148	dpavlin	14	sub subject_search_filter {
149			my $s = shift;
150			# remove re: fdw: [list] preffixes from e-mail
151	dpavlin	16	while ( $s =~ s/^\s\[(?:re\|fwd\|fw):\s+(.+)\]\s$/$1/ig \|\|
152			$s =~ s/^\s(?:re\|fwd\|fw):\s+(.+?)\s$/$1/ig \|\|
153			$s =~ s/^\[\S+\]\s*//ig \|\|
154			$s =~ s/^\[[^@]+@\w+\.\w+\s:\s+(.+)\s\]\s*$/$1/g
155	dpavlin	14	) { };
156			return $s;
157			}