]> git.treefish.org Git - fex.git/blob - lib/dop
Original release 20150615
[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 = '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       $s = $size;
311     } else {
312       # binary data # can be stream!
313       seek $file,$seek,0 if $seek;
314       while ($b = read($file,$data,$bs)) {
315         if ($stop and $s+$b > $size) {
316           $b = $size-$s;
317           $data = substr($data,0,$b)
318         }
319         $s += $b;      
320         alarm($timeout*10);
321         print $data or last;
322       }
323     }
324     fdlog($log,$file,$s,$size) if $s;
325   }
326   
327   alarm(0);
328   close $file;
329   exit if @files; # streaming end
330   return $s;
331 }
332
333
334 # show directory index
335 sub showindex {
336   my $dir = shift;
337   my ($htmldoc,$size);
338   my @links = ();
339   my @dirs = ();
340   my @files = ();
341   my $uri = $ENV{REQUEST_URI};
342   my $allowed;
343   my ($htindex,$htauth);
344   local $_;
345   
346   $uri =~ s:/+$::;
347   $dir =~ s:/+$::;
348
349   security_check($dir);
350   
351   $htindex = "$dir/.htindex";
352   $htauth  = "$dir/.htauth";
353   
354   open $htindex,$htindex or http_error(403);
355   require_auth($htauth,$dir) if -f $htauth;
356   
357   # .htindex may contain listing regexp
358   chomp ($allowed = <$htindex>||'.');
359   close $htindex;
360   
361   opendir $dir,$dir or http_error(503);
362   while (defined($_ = readdir $dir)) {
363     next if /^[.#]/ or /~$/;
364     if (@s = lstat "$dir/$_" and ($s[2] & (S_IRGRP|S_IROTH))) {
365       if    (-l _) { push @links,$_ }
366       elsif (-d _) { push @dirs,$_ }
367       elsif (-f _) { push @files,$_ }
368     }
369   }
370   closedir $dir;
371
372   # parent directory listable?
373   if ($uri =~ m:(/.+)/.+: and -f "$dir/../.htindex") {
374     unshift @dirs,$1;
375   }
376
377   # first the (sub)directories
378   $htmldoc = "<HTML>\n<h1>$uri/</h1>\n";
379   foreach my $d (sort @dirs) {
380     if ($d =~ m:^/: and -f "$d/.htindex") {
381       $htmldoc .= "<h3><a href=\"$d/\">$d/</a></h3>\n";
382     } elsif (-f "$dir/$d/.htindex") {
383       $htmldoc .= "<h3><a href=\"$uri/$d/\">$uri/$d/</a></h3>\n";
384     }
385   }
386   
387 #  # then the symlinks
388 #  $htmldoc .= "\n<pre>\n";
389 #  my $link;
390 #  foreach my $l (sort @links) {
391 #    if ($l =~ /$allowed/ and $link = readlink "$dir/$l" and $link =~ /^[^.\/]/) {
392 #      $htmldoc .= "$l -> <a href=\"$link\">$dir/$link</a>\n";
393 #    }
394 #  }
395   
396   # then the files
397   $htmldoc .= "\n<pre>\n";
398   foreach my $f (sort @files) {
399     if ($f =~ /$allowed/) {
400       $htmldoc .= sprintf "%20s %20s <a href=\"%s/%s\">%s</a>\n",
401                           isodate(mtime("$dir/$f")),
402                           d3(-s "$dir/$f"||0),
403                           $uri,urlencode($f),$f;
404     }
405   }
406   $htmldoc .= "</pre>\n</HTML>\n";
407   
408   $size = length($htmldoc);
409   nvt_print(
410     'HTTP/1.1 200 OK',
411     'Server: fexsrv',
412     "Content-Length: $size",
413     "Content-Type: text/html",
414     '',
415   );
416   print $htmldoc;
417   fdlog($log,"$dir/",$size,$size);
418 }
419
420
421 sub d3 {
422   local $_ = shift;
423   while (s/(\d)(\d\d\d\b)/$1,$2/) {};
424   return $_;
425 }
426
427
428 sub http_date {
429   my $file = shift;
430   my @stat;
431   
432   if (@stat = stat($file)) {
433     return strftime("%a, %d %b %Y %T GMT",gmtime($stat[9]));
434   } else {
435     return 0;
436   }
437 }
438
439
440 sub path_match {
441   my $p1 = abs_path(shift);
442   my $p2 = abs_path(shift);
443
444   if (defined $p1 and defined $p2) {
445     return 1 if $p1          =~ /^\Q$p2/;
446     return 2 if dirname($p1) =~ /^\Q$p2/;
447   }
448   return 0;
449 }
450
451
452 # return real file name (from symlink)
453 sub realfilename {
454   my $file = shift;
455   
456   return '' unless -e $file;
457   
458   if (-l $file) {
459     return realfilename(readlink($file));
460   } else {
461     return $file;
462   }
463 }
464
465
466 sub security_check {
467   my $file = shift; # can be directory, too!
468   my @s;
469
470   # client ip allowed?
471   access_check($file);
472
473   # documents with leading . are not allowed
474   if (abs_path($file) =~ /\/\./) {
475     errorlog("$file with leading .");
476     http_error(403);
477   }
478
479   if (-f $file) {
480
481     # document filename must not contain @
482     if (realfilename($file) =~ /@/ or abs_path($file) =~ /@/) {
483       errorlog("$file contains @");
484       http_error(403);
485     }
486   
487     # document filename must not end with ~
488     if (realfilename($file) =~ /~$/) {
489       errorlog("$file ends with ~");
490       http_error(403);
491     }
492   
493     # file must be group or world readable
494     if (@s = stat($file) and not($s[2] & (S_IRGRP|S_IROTH))) {
495       errorlog("$file not group or world readable");
496       http_error(403);
497     }
498
499     # symlink to regular file and symlink owned by root or fex? ==> ok!
500     if (-l $file and path_match(dirname($file),$docdir)) {
501       @s = lstat($file);
502       return if $s[4] == 0 or $s[4] == $<;
503     }
504     
505   }
506   
507   # file in allowed directory? ==> ok!
508   foreach my $dir (@doc_dirs) {
509     return if path_match($file,$dir);
510   }
511   
512   errorlog("$file not in \@doc_dirs");
513   http_error(403);
514 }
515
516 # security check: client ip allowed?
517 sub access_check {
518   my $file = abs_path(shift);
519   my $dir = $file;
520   my $af;
521   local $_;
522
523   $dir .= '/x' if -d $dir;
524   
525   while ($dir = dirname($dir) and $dir ne '/') {
526     $af = "$dir/.htaccessfrom";
527     if (open $af,$af) {
528       while (<$af>) {
529         s/\s//g;
530         if (ipin($ra,$_)) {
531           close $af;
532           return;
533         }
534       }
535       errorlog("no access to $file by $af");
536       http_error(403);
537     }
538   }
539     
540 }
541
542 # HTTP Basic authentication
543 sub require_auth {
544   my $htauth = shift;
545   my $doc = shift;
546   my ($realm,$auth);
547   my @http_auth;
548   my $uri = $ENV{REQUEST_URI} || '/';
549   
550   $uri =~ s/\/index\.html$//;
551   $uri =~ s/\/$//;
552
553   if (-d $doc or $doc =~ /\/index\.html$/) {
554     $realm = $uri;
555   } else {
556     $realm = dirname($uri);
557   }
558   
559   $auth = slurp($htauth);
560   unless ($auth and $realm) {
561     http_header("200 OK");
562     print html_header("$ENV{SERVER_NAME} no authentication");
563     pq(qq(
564       '<h3><code>$htauth</code> missing</h3>'
565       '</body></html>'
566     ));
567     exit;
568   }
569   chomp $auth;
570   
571   if ($ENV{HTTP_AUTHORIZATION} and $ENV{HTTP_AUTHORIZATION} =~ /Basic\s+(.+)/) 
572   { @http_auth = split(':',decode_b64($1)) }
573   if (@http_auth != 2 or $http_auth[1] ne $auth) {
574     http_header(
575       '401 Authorization Required',
576       "WWW-Authenticate: Basic realm=\"$realm\"",
577       'Content-Length: 0',
578     );
579     # control back to fexsrv for further HTTP handling
580     &reexec;
581   }
582 }
583
584
585 # function for <<perl-code>> inside HTML documents
586 sub out {
587   $__ .= join('',@_);
588   return '';
589 }
590
591 # tie STDOUT to buffer variable (redefining print)
592 package Buffer;
593
594 sub TIEHANDLE { 
595   my ($class,$buffer) = @_; 
596   bless $buffer,$class; 
597 }
598
599 sub PRINT { 
600   my $buffer = shift; 
601   $$buffer .= $_ foreach @_; 
602 }
603
604 sub PRINTF { 
605   my $buffer = shift; 
606   my $fmt = shift @_;
607   $$buffer .= sprintf($fmt,@_);
608 }
609
610 1;