]> git.treefish.org Git - fex.git/blob - lib/dop
df9511b70538fcd64f69ac88444d05805ea74283
[fex.git] / lib / dop
1 #!/usr/bin/perl -wT
2
3 # F*EX document output
4 #
5 # is a subprogram of fexsrv! do not run it directly!
6 #
7 # Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
8 #
9
10 use File::Basename;
11 use CGI::Carp   qw(fatalsToBrowser);
12 use Fcntl       qw(:flock :seek :mode);
13 use POSIX       qw(strftime locale_h);
14 use Cwd         qw(getcwd abs_path);
15
16 # import from fex.pp
17 our ($bs,$tmpdir,@doc_dirs);
18
19 my $log = "$logdir/dop.log";
20
21 # POSIX time format needed for HTTP header
22 setlocale(LC_TIME,'POSIX');
23
24 sub dop {
25   my $doc = shift;
26   my $source = shift;
27   my $seek = 0;
28   my $stop = 0;
29   my ($link,$host,$path,$range);
30   
31   our $error = 'F*EX document output ERROR';
32   
33   security_check($doc);
34   
35   # reget?
36   if ($range = $ENV{HTTP_RANGE}) {
37     $seek = $1 if $range =~ /^bytes=(\d+)-/i;
38     $stop = $1 if $range =~ /^bytes=\d*-(\d+)/i;
39   }
40
41   # redirect on relative symlinks without "../" 
42   if ($link = readlink($doc) and 
43       $link !~ m:^/: and $link !~ m:\.\./: and $link !~ /^:.+:$/) {
44     $path = $ENV{REQUEST_URI};
45     $path =~ s:[^/]*$::;
46     $doc = "$path/$link";
47     $doc =~ s:/+:/:g;
48     $doc =~ s:^/::;
49     $host = $ENV{HTTP_HOST} || $hostname;
50     nvt_print(
51       "HTTP/1.1 301 Moved Permanently",
52       "Location: $ENV{PROTO}://$host/$doc",
53       "Content-Length: 0",
54       "Connection: close",
55       ""
56     );
57     &reexec;
58   }
59
60   # watchdog documents
61   if (@wdd and $wdd and grep { $doc =~ /$_/ } @wdd) { &$wdd($doc) }
62
63   my $dir = untaint(getcwd());
64   chdir(dirname($doc));
65   http_output($doc,$seek,$stop);
66   chdir($dir);
67 }
68
69 sub http_output {
70   my ($file,$seek,$stop) = @_;
71   my ($filename,$files,$streamfile,$size,$total_size);
72   my ($data,$type);
73   my ($var,$env,$con);
74   my @files;
75   my $htmldoc = '';
76   my $htauth;
77   my @s;
78   my $s = 0;
79   my $b = 0;
80   my $http_client = $ENV{HTTP_USER_AGENT} || '';
81   local $_;
82
83   # extra security check: document must not be in lib or spool directory
84   if (path_match($file,$FEXLIB) or path_match($file,$spooldir)) {
85     http_error(403);
86   }
87
88   security_check($file);
89   $htauth = dirname($file).'/.htauth';
90   require_auth($htauth,$file) if -f $htauth;
91
92   if (-f $file) {
93     # normal file
94     open $file,'<',$file or http_error(400);
95     security_check($file);
96   } elsif ($file =~ /(.+)\.gz$/ and -f $1) {
97     @files = ($1);
98     open $file,'-|',qw'gzip -c',@files or http_error(503);
99   } elsif ($file =~ /(.+)\.tgz$/ and -f "$1.tar") {
100     @files = ("$1.tar");
101     open $file,'-|',qw'gzip -c',@files or http_error(503);
102   } elsif ($file =~ /(.+)\.(tar|tgz|zip)$/ and 
103            @s = lstat($streamfile = "$1.stream") and $s[4] == $<)
104   {
105     # streaming file (only if it is owned by user fex)
106     chdir dirname($file);
107     security_check($file);
108     if (-l $streamfile and readlink($streamfile) =~ /^:(.+):$/) {
109       # special symlink pointer file for streaming
110       @files = split(/:/,$1);
111     } elsif (open $streamfile,$streamfile) {
112       # special streaming file
113       while (<$streamfile>) {
114         chomp;
115         if (/^(\/.*):/) {
116           chdir $1;
117           security_check($1);
118         } else {
119           push @files,$_;
120         }
121       }
122     } else {
123       http_error(503);
124     }
125     close $streamfile;
126     foreach (@files) {
127       if (/^\// or /\.\.\//) { 
128         # absolute path or relative path with parent directory is not allowed
129         http_error(403);
130       }
131       if (@s = stat($_) and not($s[2] & S_IRGRP) or not -r $_) { 
132         # file must be readable by user and group
133         http_error(403);
134       }
135     }
136     http_error(416) if $ENV{HTTP_RANGE};
137     close STDERR;
138     if    ($file =~ /\.tar$/) { @a = qw'tar --exclude *~ --exclude .* -cf -' } 
139     elsif ($file =~ /\.tgz$/) { @a = qw'tar --exclude *~ --exclude .* -czf -' }
140     elsif ($file =~ /\.zip$/) { @a = qw'zip -x *~ */.*/* @ -rq -' }
141     else { http_error(400) }
142     open $file,'-|',@a,@files or http_error(503);
143   } else {
144     http_error(404);
145   }
146   
147   $type = 'application/octet-stream';
148   if    ($file =~ /\.html$/)    { $type = 'text/html' } 
149   # elsif ($file =~ /\.txt$/)   { $type = 'text/plain' }
150   elsif ($file =~ /\.css$/)     { $type = 'text/css' }
151   elsif ($file =~ /\.js$/)      { $type = 'text/javascript' }
152   elsif ($file =~ /\.ps$/)      { $type = 'application/postscript' }
153   elsif ($file =~ /\.pdf$/)     { $type = 'application/pdf' }
154   elsif ($file =~ /\.jpg$/)     { $type = 'image/jpeg' }
155   elsif ($file =~ /\.png$/)     { $type = 'image/png' }
156   elsif ($file =~ /\.gif$/)     { $type = 'image/gif' }
157   elsif ($file !~ /\.(tar|tgz|zip|jar|rar|arj|7z|bz2?|gz)$/) {
158     my $qfile = untaint(abs_path($file));
159     $qfile =~ s/([^\/\.\+\w!=,_-])/\\$1/g;
160     $_ = `file $qfile`;
161     if (/HTML/) {
162       $type = 'text/html';
163     } elsif (/text/i and not -x $file) {
164       $type = 'text/plain';
165       if    (/\sASCII\s/)    { $type .= "; charset=us-ascii" }
166       elsif (/(ISO-[\w-]+)/) { $type .= "; charset=".lc($1) }
167       else                   { $type .= "; charset=utf-8" }
168     }
169   }
170
171   # show sourcecode if URL ends with '!'
172   # to avoid this for a HTML file, simple do a: chmod o-r file
173   if ($type eq 'text/html') {
174     if ($htmlsource) {
175       if (@s = stat($file) and $s[2] & S_IROTH) {
176         $type = 'text/plain';
177       } else {
178         http_error(403);
179       }
180     }
181   } elsif ($ENV{'QUERY_STRING'} eq '!') {
182     $type = 'text/plain';
183   }
184       
185   
186   if ($type eq 'text/html') {
187     $seek = $stop = 0;
188     local $^W = 0;
189     local $/;
190     $htmldoc = <$file>;
191     while ($htmldoc =~ s/\n##.*?\n/\n/) {};
192     # evaluate #if ... #else ... #elseif ... #endif blocks
193     my $mark = randstring(16);
194     while ($htmldoc =~ s/\n(#if\s+(.+?)\n.+?\n)#endif/\n$mark/s) {
195       $_ = $1;
196       # if block
197       if (eval $2) {
198         s/#if.*\n//;
199         s/\n#else.*//s;
200         $htmldoc =~ s/$mark/$_/;
201       } else {
202         # elseif blocks
203         while (s/.*?\n#elseif\s+(.+?)\n//s) {
204           if (eval $1) {
205             s/\n#else.*//s;
206             $htmldoc =~ s/$mark/$_/;
207           }
208         }
209         # else block left?
210         if ($htmldoc =~ /$mark/) {
211           s/.*\n#else\s*\n//s or $_ = '';
212           $htmldoc =~ s/$mark/$_/;
213         }
214       }
215     };
216     # evaluate #include
217     while ($htmldoc =~ s/\n#include "(.*?)"/\n$mark/s) {
218       my $file = $1;
219       my $include = '';
220       if (open $file,$file) {
221         $include = <$file>;
222         close $file;
223       }
224       $dynamic = $htmldoc =~ s/$mark/$include/;
225     }
226     # evaluate <<perl-code>>
227     while ($htmldoc =~ /<<(.+?)>>/s) {
228       local $pc = $1;
229       local $__ = '';
230       tie *STDOUT => "Buffer",\$__;
231       $__ .= eval $pc;
232       untie *STDOUT;
233       $dynamic = $htmldoc =~ s/<<(.+?)>>/$__/s;
234     };
235     # substitute $variable$ with value from environment (if present)
236     while ($htmldoc =~ /\$([\w_]+)\$/g) {
237       $var = $1;
238       if (defined($env = $ENV{$var})) {
239         $htmldoc =~ s/\$$var\$/$env/g;
240       }
241     };
242     $total_size = $size = $s = length($htmldoc);
243   } else {
244     if (@files) {
245       $size = 0;
246     } else {
247       $total_size = -s $file || 0;
248       $size = $total_size - $seek - ($stop ? $total_size-$stop-1 : 0);
249     }
250   }
251
252   if ($size < 0) {
253     http_header('416 Requested Range Not Satisfiable');
254     exit;
255   }
256   
257   alarm($timeout*10);
258   
259   if ($seek or $stop) {
260     my $range;
261     if ($stop) {
262       $range = sprintf("bytes %s-%s/%s",$seek,$stop,$total_size);
263     } else {
264       $range = sprintf("bytes %s-%s/%s",$seek,$total_size-1,$total_size);
265     }
266     nvt_print(
267       'HTTP/1.1 206 Partial Content',
268       'Server: fexsrv',
269       "Content-Length: $size",
270       "Content-Range: $range",
271       "Content-Type: $type",
272       '',
273     );
274   } else {
275     # streaming?
276     if (@files) {
277       nvt_print(
278         'HTTP/1.1 200 OK',
279         'Server: fexsrv',
280         "Expires: 0",
281         "Content-Type: $type",
282         '',
283       );
284     } else {
285       # Java (clients) needs Last-Modified header!
286       # if there are locale versions, use actual time for Last-Modified
287       # to enforce reload of page
288       $file =~ m{/htdocs/(.+)};
289       my @lfiles = glob("$FEXHOME/locale/*/htdocs/$1");
290       my $date = ($dynamic or @lfiles > 1) ?
291                  strftime("%a, %d %b %Y %T GMT",gmtime(time)) :
292                  http_date($file);
293       nvt_print(
294         'HTTP/1.1 200 OK',
295         'Server: fexsrv',
296         "Last-Modified: $date",
297         "Expires: 0",
298         "Content-Length: $size",
299         "Content-Type: $type",
300       );
301       nvt_print("Set-Cookie: locale=$locale") if $use_cookies and $locale;
302       nvt_print('');
303     }
304   }
305
306   if ($ENV{REQUEST_METHOD} eq 'GET') {
307     if ($type eq 'text/html') {
308       alarm($timeout*10);
309       print $htmldoc;
310     } else {
311       # binary data # can be stream!
312       seek $file,$seek,0 if $seek;
313       while ($b = read($file,$data,$bs)) {
314         if ($stop and $s+$b > $size) {
315           $b = $size-$s;
316           $data = substr($data,0,$b)
317         }
318         $s += $b;      
319         alarm($timeout*10);
320         print $data or last;
321       }
322     }
323     fdlog($log,$file,$s,$size) if $s;
324   }
325   
326   alarm(0);
327   close $file;
328   exit if @files; # streaming end
329   return $s;
330 }
331
332
333 # show directory index
334 sub showindex {
335   my $dir = shift;
336   my ($htmldoc,$size);
337   my @links = ();
338   my @dirs = ();
339   my @files = ();
340   my $uri = $ENV{REQUEST_URI};
341   my $allowed;
342   my ($htindex,$htauth);
343   local $_;
344   
345   $uri =~ s:/+$::;
346   $dir =~ s:/+$::;
347
348   security_check($dir);
349   
350   $htindex = "$dir/.htindex";
351   $htauth  = "$dir/.htauth";
352   
353   open $htindex,$htindex or http_error(403);
354   require_auth($htauth,$dir) if -f $htauth;
355   
356   # .htindex may contain listing regexp
357   chomp ($allowed = <$htindex>||'.');
358   close $htindex;
359   
360   opendir $dir,$dir or http_error(503);
361   while (defined($_ = readdir $dir)) {
362     next if /^[.#]/ or /~$/;
363     if (@s = lstat "$dir/$_" and ($s[2] & (S_IRGRP|S_IROTH))) {
364       if    (-l _) { push @links,$_ }
365       elsif (-d _) { push @dirs,$_ }
366       elsif (-f _) { push @files,$_ }
367     }
368   }
369   closedir $dir;
370
371   # parent directory listable?
372   if ($uri =~ m:(/.+)/.+: and -f "$dir/../.htindex") {
373     unshift @dirs,$1;
374   }
375
376   # first the (sub)directories
377   $htmldoc = "<HTML>\n<h1>$uri/</h1>\n";
378   foreach my $d (sort @dirs) {
379     if ($d =~ m:^/: and -f "$d/.htindex") {
380       $htmldoc .= "<h3><a href=\"$d/\">$d/</a></h3>\n";
381     } elsif (-f "$dir/$d/.htindex") {
382       $htmldoc .= "<h3><a href=\"$uri/$d/\">$uri/$d/</a></h3>\n";
383     }
384   }
385   
386 #  # then the symlinks
387 #  $htmldoc .= "\n<pre>\n";
388 #  my $link;
389 #  foreach my $l (sort @links) {
390 #    if ($l =~ /$allowed/ and $link = readlink "$dir/$l" and $link =~ /^[^.\/]/) {
391 #      $htmldoc .= "$l -> <a href=\"$link\">$dir/$link</a>\n";
392 #    }
393 #  }
394   
395   # then the files
396   $htmldoc .= "\n<pre>\n";
397   foreach my $f (sort @files) {
398     if ($f =~ /$allowed/) {
399       $htmldoc .= sprintf "%20s %20s <a href=\"%s/%s\">%s</a>\n",
400                           isodate(mtime("$dir/$f")),
401                           d3(-s "$dir/$f"||0),
402                           $uri,urlencode($f),$f;
403     }
404   }
405   $htmldoc .= "</pre>\n</HTML>\n";
406   
407   $size = length($htmldoc);
408   nvt_print(
409     'HTTP/1.1 200 OK',
410     'Server: fexsrv',
411     "Content-Length: $size",
412     "Content-Type: text/html",
413     '',
414   );
415   print $htmldoc;
416   fdlog($log,"$dir/",$size,$size);
417 }
418
419
420 sub mtime {
421   return (lstat shift)[9];
422 }
423
424
425 sub d3 {
426   local $_ = shift;
427   while (s/(\d)(\d\d\d\b)/$1,$2/) {};
428   return $_;
429 }
430
431
432 sub http_date {
433   my $file = shift;
434   my @stat;
435   
436   if (@stat = stat($file)) {
437     return strftime("%a, %d %b %Y %T GMT",gmtime($stat[9]));
438   } else {
439     return 0;
440   }
441 }
442
443
444 sub path_match {
445   my $p1 = abs_path(shift);
446   my $p2 = abs_path(shift);
447
448   if (defined $p1 and defined $p2) {
449     return 1 if $p1          =~ /^\Q$p2/;
450     return 2 if dirname($p1) =~ /^\Q$p2/;
451   }
452   return 0;
453 }
454
455
456 # return real file name (from symlink)
457 sub realfilename {
458   my $file = shift;
459   
460   return '' unless -e $file;
461   
462   if (-l $file) {
463     return realfilename(readlink($file));
464   } else {
465     return $file;
466   }
467 }
468
469
470 sub security_check {
471   my $file = shift; # can be directory, too!
472   my @s;
473
474   # client ip allowed?
475   access_check($file);
476
477   # documents with leading . are not allowed
478   if (abs_path($file) =~ /\/\./) {
479     errorlog("$file with leading .");
480     http_error(403);
481   }
482
483   if (-f $file) {
484
485     # document filename must not contain @
486     if (realfilename($file) =~ /@/ or abs_path($file) =~ /@/) {
487       errorlog("$file contains @");
488       http_error(403);
489     }
490   
491     # document filename must not end with ~
492     if (realfilename($file) =~ /~$/) {
493       errorlog("$file ends with ~");
494       http_error(403);
495     }
496   
497     # file must be group or world readable
498     if (@s = stat($file) and not($s[2] & (S_IRGRP|S_IROTH))) {
499       errorlog("$file not group or world readable");
500       http_error(403);
501     }
502
503     # symlink to regular file and symlink owned by root or fex? ==> ok!
504     if (-l $file and path_match(dirname($file),$docdir)) {
505       @s = lstat($file);
506       return if $s[4] == 0 or $s[4] == $<;
507     }
508     
509   }
510   
511   # file in allowed directory? ==> ok!
512   foreach my $dir (@doc_dirs) {
513     return if path_match($file,$dir);
514   }
515   
516   errorlog("$file not in \@doc_dirs");
517   http_error(403);
518 }
519
520 # security check: client ip allowed?
521 sub access_check {
522   my $file = abs_path(shift);
523   my $dir = $file;
524   my $af;
525   local $_;
526
527   $dir .= '/x' if -d $dir;
528   
529   while ($dir = dirname($dir) and $dir ne '/') {
530     $af = "$dir/.htaccessfrom";
531     if (open $af,$af) {
532       while (<$af>) {
533         s/\s//g;
534         if (ipin($ra,$_)) {
535           close $af;
536           return;
537         }
538       }
539       errorlog("no access to $file by $af");
540       http_error(403);
541     }
542   }
543     
544 }
545
546 # HTTP Basic authentication
547 sub require_auth {
548   my $htauth = shift;
549   my $doc = shift;
550   my ($realm,$auth);
551   my @http_auth;
552   my $uri = $ENV{REQUEST_URI} || '/';
553   
554   $uri =~ s/\/index\.html$//;
555   $uri =~ s/\/$//;
556
557   if (-d $doc or $doc =~ /\/index\.html$/) {
558     $realm = $uri;
559   } else {
560     $realm = dirname($uri);
561   }
562   
563   $auth = slurp($htauth);
564   unless ($auth and $realm) {
565     http_header("200 OK");
566     print html_header("$ENV{SERVER_NAME} no authentication");
567     pq(qq(
568       '<h3><code>$htauth</code> missing</h3>'
569       '</body></html>'
570     ));
571     exit;
572   }
573   chomp $auth;
574   
575   if ($ENV{HTTP_AUTHORIZATION} and $ENV{HTTP_AUTHORIZATION} =~ /Basic\s+(.+)/) 
576   { @http_auth = split(':',decode_b64($1)) }
577   if (@http_auth != 2 or $http_auth[1] ne $auth) {
578     http_header(
579       '401 Authorization Required',
580       "WWW-Authenticate: Basic realm=\"$realm\"",
581       'Content-Length: 0',
582     );
583     # control back to fexsrv for further HTTP handling
584     &reexec;
585   }
586 }
587
588
589 # function for <<perl-code>> inside HTML documents
590 sub out {
591   $__ .= join('',@_);
592   return '';
593 }
594
595 # tie STDOUT to buffer variable (redefining print)
596 package Buffer;
597
598 sub TIEHANDLE { 
599   my ($class,$buffer) = @_; 
600   bless $buffer,$class; 
601 }
602
603 sub PRINT { 
604   my $buffer = shift; 
605   $$buffer .= $_ foreach @_; 
606 }
607
608 sub PRINTF { 
609   my $buffer = shift; 
610   my $fmt = shift @_;
611   $$buffer .= sprintf($fmt,@_);
612 }
613
614 1;