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