/[mws]/trunk/httpd.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/httpd.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 6 by dpavlin, Wed May 5 13:42:27 2004 UTC revision 47 by dpavlin, Tue May 11 22:59:27 2004 UTC
# Line 3  Line 3 
3  # based on post  # based on post
4  # http://www.mail-archive.com/libwww@perl.org/msg04750.html  # http://www.mail-archive.com/libwww@perl.org/msg04750.html
5    
6    BEGIN {
7            my $basedir = readlink($0) || $0; $basedir =~ s#/[^/]+$##;
8            unshift(@INC, $basedir);
9    }
10    
11    =head1 NAME
12    
13    httpd.pl - http server for Mail::Box Web Search
14    
15    =head1 SYNOPSYS
16    
17     httpd.pl [local.conf]
18    
19    =head1 DESCRIPTION
20    
21    This is small http server, based on C<HTTP::Daemon> which is designed
22    for single-user use (on laptop for example) via loopback.
23    
24    It doesn't provide any authentification or authorisation, and it can handle
25    just one request at the time, so it's not suted for public-facing sites,
26    even if you don't care about security of your mailboxes.
27    
28    =head1 SEE ALSO
29    
30    C<MWS> perl modules which are part of this package
31    
32    =cut
33    
34  use strict;  use strict;
35  use warnings;  use warnings;
36    use MWS::SWISH;
37    #use MWS::Plucene;
38  use HTTP::Daemon;  use HTTP::Daemon;
39  use HTTP::Status;  use HTTP::Status;
40  use IO::String;  use IO::String;
41  use CGI::Lite;  use CGI::Lite;
42  use Template;  use Template;
43  use MWS;  use URI::Escape;
44    
45  use Data::Dumper;  use Data::Dumper;
46    
47  my $d = HTTP::Daemon->new( Reuse => 1, LocalPort => 6969 ) || die;  my $debug = 1;
48  print "Please contact me at: <URL:", $d->url, ">\n";  
49    my $config_file = shift @ARGV || 'global.conf';
50    
51    if (! -f $config_file) {
52            print qq{Usage: $0 [/path/to/local.conf]
53    
54    If local.conf is not specified, global.conf in current directory will
55    be used.
56    };
57            exit 1;
58    }
59    
60    my $mws = MWS::SWISH->new(config_file => $config_file);
61    #my $mws = MWS::Plucene->new(config_file => $config_file, debug => $debug);
62    
63    my ($local_addr,$local_port) = ('127.0.0.1',6969);
64    
65    my $listen = $mws->{config}->val('global', 'listen');
66    
67    print STDERR "using listen $listen\n" if ($listen);
68    
69    if ($listen && $listen =~ m/:/) {
70            ($local_addr,$local_port) = split(/:/,$listen,2);
71    } elsif ($listen) {
72            $local_addr = $listen;
73    }
74    
75    my $d = HTTP::Daemon->new(
76            Reuse => 1,
77            LocalAddr => $local_addr,
78            LocalPort => $local_port,
79    ) || die "can't create HTTP::Daemon on $local_addr:$local_port: $!";
80    
81  my $cgi = new CGI::Lite;  my $cgi = new CGI::Lite;
 my $mws = MWS->new('global.conf');  
82  my $tt = Template->new({  my $tt = Template->new({
83          INCLUDE_PATH => $mws->{config}->val('global', 'templates'),          INCLUDE_PATH => $mws->{config}->val('global', 'templates'),
84          FILTERS => {          FILTERS => {
85                  'body5' => \&body5_filter,                  'body5' => \&body5_filter,
86                    'body' => \&body_filter,
87          },          },
88            EVAL_PERL => 1,
89  });  });
90    
91    my $static_html = $mws->{config}->val('global', 'static_html');
92    
93    print "Web server ready at: ", $d->url, "\n";
94    
95    
96  while ( my $c = $d->accept ) {  while ( my $c = $d->accept ) {
97          while ( my $r = $c->get_request ) {          while ( my $r = $c->get_request ) {
# Line 67  while ( my $c = $d->accept ) { Line 133  while ( my $c = $d->accept ) {
133                  my $url = $r->url->path;                  my $url = $r->url->path;
134    
135                  # XXX LOG                  # XXX LOG
136                  print $r->method," ",$url,Dumper($param);                  print $r->method," ",$url,"\n";
137                    print Dumper($param,$mws->{counter}),"\n" if ($debug);
138    
139                    # is this static page?
140                    if ($static_html && -f "$static_html/$url") {
141                            print "static file: $static_html/$url\n" if ($debug);
142                            $c->send_file_response("$static_html/$url");
143                            $c->close;
144                            next;
145                    }
146    
147                  # generate HTML                  # template file name (use ?format=html as default)
148                    my $tpl_file = 'master.';
149                    $tpl_file .= $param->{'format'} || 'html';
150    
151                    # parse date from url
152                    my ($yyyy,$mm,$dd) = $mws->yyyymmdd;
153    
154                    my $yyyymm;
155    
156                    my $date_limit;
157    
158                    if ($url =~ m,^/(\d{4})[/-](\d+)[/-](\d+),) {
159                            ($yyyy, $mm, $dd) = $mws->fmtdate($1,$2,$3);
160                             $date_limit = "$yyyy-$mm-$dd";
161                    } elsif ($url =~ m,^/(\d{4})[/-](\d+),) {
162                            ($yyyy,$mm) = $mws->fmtdate($1,$2);
163                            $date_limit = "$yyyy-$mm";
164                    } elsif ($url =~ m,^/(\d{4}),) {
165                            $date_limit = $mws->fmtdate($1);
166                    }
167    
168                    #
169                    # implement functionality and generate HTML
170                    #
171                  my $html;                  my $html;
172    
173                  my $s=$param->{'search'};                  if ($param->{'search_val'} && $param->{'search_fld'} && !$param->{'search'}) {
174                            $param->{'search'} = $param->{'search_fld'}.":".$param->{'search_val'};
175                    } elsif ($param->{'search'}) {
176                            ($param->{'search_fld'}, $param->{'search_val'}) = split(/:/,$param->{'search'},2);
177                    }
178    
179                    my $tpl_var = {
180                            param   => $param,
181                            yyyy    => $yyyy,
182                            mm      => $mm,
183                            dd      => $dd,
184                            date_limit => $date_limit,
185                    };
186    
187                    # is this access to root of web server?
188                    if ($url eq "/" && !$param->{'search'}) {
189                            # if first access, go to current year
190                            $date_limit = $mws->fmtdate($yyyy);
191                            $param->{sort_by} = "date desc";
192                    }
193    
194                    # ?show_id=XXXXxxxx___message_id___xxxxXXXX
195                    if ($param->{'show_id'}) {
196    
197                  if ($s) {                          $mws->reset_counters;
198                            my $row = $mws->fetch_result_by_id($param->{'show_id'});
199                            $tpl_var->{message} = $row;
200                    } elsif ($param->{'search'} || $date_limit) {
201    
202                            # show search results
203                            # ?search=foo:bar
204    
205                            my @search;
206                            push @search, $param->{'search'} if ($param->{'search'});
207    
208                            if ($date_limit) {
209                                    push @search, "and" if (@search);
210                                    push @search, "date:\"$date_limit\"";
211                            }
212    
213                          print STDERR "search: $s\n";                          if ($param->{sort_by}) {
214                                    push @search, "sort:".$param->{sort_by};
215                            }
216    
217                          my $results = $mws->search($s);                          print STDERR "search: ",join(" ",@search),"\n";
218    
219                            my $results = $mws->search(@search);
220                          my @res = $mws->fetch_all_results();                          my @res = $mws->fetch_all_results();
221    
222                          my $tpl_file = 'master.';                          $tpl_var->{results} = \@res if (@res);
223                          $tpl_file .= $param->{'format'} || 'html';                          $tpl_var->{total_hits} = $mws->{total_hits} || 0;
224    
225                            # no hits, offer suggestions
226                            if (! $tpl_var->{results}) {
227                                    @{$tpl_var->{apropos}} = $mws->apropos_index($param->{'search_fld'}, $param->{'search_val'});
228                            }
229    
                         $tt->process($tpl_file, {  
                                 query   => $s,  
                                 results => \@res,  
                                 param   => $param,  
                         }, \$html) || die $tt->error();  
230                  }                  }
231    
232    
233                    # push counters to template
234                    foreach my $f (qw(from to cc bcc folder)) {
235                            my $h = $mws->counter($f) || next;
236                            my @a;
237                            foreach my $k (sort { $h->{$b}->{usage} <=> $h->{$a}->{usage} } keys %$h) {
238                                    push @a, $h->{$k};
239                            }
240                            $tpl_var->{counters}->{$f} = [ @a ] if (@a);
241                    }
242    
243                    # push calendar in template
244                    $tpl_var->{calendar} = $mws->counter('calendar');
245    
246                    $tt->process($tpl_file, $tpl_var, \$html) || die $tt->error();
247    
248                    #
249                    # send HTMLto client
250                    #
251    
252                  my $res = HTTP::Response->new(RC_OK);                  my $res = HTTP::Response->new(RC_OK);
253                  $res->header( 'Content-type' => 'text/html; charset=iso-8859-2' );                  $res->header( 'Content-type' => 'text/html; charset=ISO-8859-2' );
254                  $res->content($html);                  $res->content($html);
255                  $c->send_response($res);                  $c->send_response($res);
256    
# Line 104  while ( my $c = $d->accept ) { Line 261  while ( my $c = $d->accept ) {
261    
262  # template toolkit filter  # template toolkit filter
263    
264    sub html_escape($) {
265            my $text = shift || return;
266    
267            # don't re-escape html
268            #return $text if ($text =~ /&(?:lt|gt|amp|quot);/);
269    
270            # Escape <, >, & and ", and to produce valid XML
271            my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
272            my $escape_re  = join '|' => keys %escape;
273    
274            $text =~ s/($escape_re)/$escape{$1}/gs;
275    
276            while ($text =~ s/#-#(quote|signature)(\d*)##(.+?)##\1\2#-#/<span class="$1">$3<\/span>/gs) { } ;
277    
278            return $text;
279    }
280    
281    #use Text::Context::EitherSide;
282    
283  sub body5_filter {  sub body5_filter {
284          my $text = shift;          my $text = shift;
285          $text =~ s/^\s+//gs;  
286          $text =~ s/^(.*?[\n\r]+){5}.*$/$1/s;          # remove quote
287            $text =~ s/^[\>:\|=]+[^\n\r]*[\n\r]*$/#-q-#/msg;
288            # remove quote author
289            $text =~ s/[\n\r]+[^\n\r]+:\s*(?:#-q-#[\n\r*])+//gs;
290            $text =~ s/^[^\n\r]+:\s*(?:#-q-#[\n\r]*)+//gs;
291            $text =~ s/#-q-#[\n\r]*//gs;
292            # outlook quoting
293            $text =~ s/(\s*--+\s*Original\s+Message\s*--+.*)$//si;
294            $text =~ s/(\s*--+\s*Forwarded\s+message.+\s*--+.*)$//si;
295    
296            # remove signature
297            $text =~ s/(?:^|[\n\r]+)*--\s*[\n\r]+.*$//s;
298            $text =~ s/(?:^|[\n\r]+)*_____+[\n\r]+.*$//s;
299    
300            # compress cr/lf
301            $text =~ s/[\n\r]+/\n/gs;
302    
303            # remove whitespaces
304            $text =~ s/^\n+//gs;
305            $text =~ s/[\s\n]+$//gs;
306    
307            if ($text eq "") {
308                    $text="#-#quote##forwarded message##quote#-#";
309            }
310    
311            # cut to 5 lines;
312            if ($text =~ s,^((?:.*?[\n\r]){5}).*$,$1,s) {
313                    $text =~ s/[\n\r]*$/ .../;
314            }
315    
316    #       my $context = Text::Context::EitherSide->new($text, context => 5);
317    #       return $context->as_string("perl");
318    
319            return html_escape($text);
320    }
321    
322    sub body_filter {
323            my $text = shift;
324    
325            my $sig = '';
326    
327            # remove signature
328            if ($text =~ s/([\n\r]+)(--\s*[\n\r]+.*)$//s) {
329                    $sig = "$1#-#signature##$2##signature#-#";
330            } elsif ($text =~s/(^|[\n\r]+)*(_____+[\n\r]+.*)$//s) {
331                    $sig = "$1#-#signature##$2##signature#-#";
332            }
333    
334            # find quoted text
335            $text =~ s/^([\>:\|=]+[^\n\r]*[\n\r]*)$/#-#quote1##$1##quote1#-#/mg;
336            $text =~ s/(--+\s*Original\s+Message\s*--+.*)$/#-#quote2##$1##quote2#-#/si;
337            $text =~ s/(--+\s*Forwarded\s+message.+\s*--+.*)$/#-#quote3##$1##quote3#-#/si;
338    
339            $text = html_escape($text . $sig);
340          return $text;          return $text;
341  }  }
342    
Legend:
Removed from v.6  
changed lines
  Added in v.47
  ViewVC Help
Powered by ViewVC 1.1.26