X-Git-Url: https://git.treefish.org/fex.git/blobdiff_plain/e60096926213ce02293a261254ff065cae44c1c8..c65ee6f7429eff9a7f58aad7c0aec858ad473092:/cgi-bin/fop diff --git a/cgi-bin/fop b/cgi-bin/fop index 949f084..dec3abc 100755 --- a/cgi-bin/fop +++ b/cgi-bin/fop @@ -7,6 +7,7 @@ BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 } +use utf8; use Fcntl qw':flock :seek'; use Cwd qw'abs_path'; use File::Basename; @@ -90,11 +91,11 @@ if ($file =~ m:^([^/]+)/[^/]+$:) { if ($ENV{REQUEST_METHOD} eq 'GET' and $file =~ m:.+/(.+)/.+:) { $from = lc $1; - if (-s "$from/\@ALLOWED_RECIPIENTS") { + if (-s "$from/\@ALLOWED_RECIPIENTS") { http_die("$from is a restricted user"); } } - + # add mail-domain to addresses if necessary if ($mdomain and $file =~ s:(.+)/(.+)/(.+):$3:) { $to = lc $1; @@ -140,7 +141,7 @@ if ($qs = $ENV{QUERY_STRING}) { # workaround for broken F*IX $qs =~ s/&ID=skey:\w+//; - + # subuser with skey? if ($qs =~ s/&*SKEY=([\w:]+)//i) { $skey = $1; @@ -172,7 +173,7 @@ if ($qs = $ENV{QUERY_STRING}) { http_die("wrong SKEY authentification"); } } - + # group member with gkey? if ($qs =~ s/&*GKEY=([\w:]+)//i) { $gkey = $1; @@ -213,12 +214,12 @@ if ($qs = $ENV{QUERY_STRING}) { http_die("wrong GKEY authentification"); } } - + # check for ID in query elsif ($qs =~ s/\&*\bID=([^&]+)//i) { $id = $1; $fop_auth = 0; - + if ($id eq 'PUBLIC') { http_header('403 Forbidden'); exit; @@ -241,7 +242,7 @@ if ($qs = $ENV{QUERY_STRING}) { } # public or anonymous recipient? (needs no auth-ID for sender) - if ($anonymous or $id eq 'PUBLIC' and + if ($anonymous or $id eq 'PUBLIC' and @public_recipients and grep /^\Q$to\E$/i,@public_recipients) { $rid = $id; } else { @@ -250,12 +251,12 @@ if ($qs = $ENV{QUERY_STRING}) { close $idf; $rid = sidhash($rid,$id); } - + unless ($id eq $rid) { debuglog("real id=$rid, id sent by user=$id"); http_die("wrong auth-ID"); } - + # set akey link for HTTP sessions # (need original id for consistant non-moving akey) if (-d $akeydir and open $idf,'<',"$from/@" and my $id = getline($idf)) { @@ -263,7 +264,7 @@ if ($qs = $ENV{QUERY_STRING}) { unlink "$akeydir/$akey"; symlink "../$from","$akeydir/$akey"; } - + my %to; COLLECTTO: foreach my $to (split(',',$to)) { if ($to !~ /.@./ and open my $AB,'<',"$from/\@ADDRESS_BOOK") { @@ -305,9 +306,9 @@ if ($qs = $ENV{QUERY_STRING}) { http_die("$to is not a legal e-mail address"); } } - + } - + if ($qs =~ /\&?KEEP=(\d+)/i) { $keep = $1; $filename = filename($file); @@ -332,15 +333,15 @@ if ($qs = $ENV{QUERY_STRING}) { "\n"; } exit; - } elsif ($qs =~ s/\&?KEEP//i) { + } elsif ($qs =~ s/\&?KEEP//i) { check_captive($file); $autodelete = 'NO'; } - + if ($qs =~ s/\&?FILEID=(\w+)//i) { $fileid = $1 } if ($qs =~ s/\&?IGNOREWARNING//i) { $ignorewarning = 1 } - + if ($qs eq 'LIST') { http_header('200 OK','Content-Type: text/plain'); print "$file :\n"; @@ -372,7 +373,7 @@ if ($qs = $ENV{QUERY_STRING}) { http_die("File $file already exists in your outgoing spool."); } mkdirp("$to/$to/$file"); - link "$to/$from/$file/data","$to/$to/$file/data" + link "$to/$from/$file/data","$to/$to/$file/data" or http_die("cannot link to $to/$to/$file/data - $!\n"); my $fkey = copy("$to/$from/$file/filename","$to/$to/$file/filename"); open my $notify,'>',"$to/$to/$file/notify"; @@ -387,7 +388,7 @@ if ($qs = $ENV{QUERY_STRING}) { "\n"; exit; } - + # ex and hopp? if ($qs =~ s/(^|&)DELETE//i) { if (unlink $data) { @@ -410,12 +411,12 @@ if ($qs = $ENV{QUERY_STRING}) { "

$filename deleted

\n", "\n"; exit; - } else { + } else { http_die("no such file"); } exit; - } - + } + # wipe out!? (for anonymous upload) if ($qs =~ s/(^|&)PURGE//i) { $filename = filename($file); @@ -434,15 +435,15 @@ if ($qs = $ENV{QUERY_STRING}) { print html_header($head), "

$filename purged

\n", "\n"; - } else { + } else { http_die("no such file"); } - } else { + } else { http_die("you are not allowed to purge $filename"); } exit; - } - + } + # request for file size? if ($qs eq '?') { sendsize($file); @@ -509,7 +510,7 @@ if ($range = $ENV{HTTP_RANGE}) { if (not $autodelete or $autodelete ne 'NO') { $autodelete = readlink "$file/autodelete" || 'YES'; } - + if ($from and $file eq "$from/$from/ADDRESS_BOOK") { if (open my $AB,'<',"$from/\@ADDRESS_BOOK") { my $ab = ''; @@ -542,29 +543,28 @@ if (-f $data) { # already downloaded? if ($limited_download and $limited_download !~ /^n/i and $from ne $to # fex to yourself is ok! - and $to !~ /$amdl/ # allowed multi download recipients and $from !~ /^_?fexmail/ # fexmail is ok! and $to !~ /^_?fexmail/ # fexmail is ok! and $to !~ /^anonymous/ # anonymous fex is ok! + and $to !~ /$amdl/ # allowed multi download recipients and $http_client !~ /$adlm/ # allowed download managers and $file !~ /\/STDFEX$/ # xx is ok! and (slurp("$file/comment")||'') !~ /^!\*!/ # multi download allow flag and not($dkey and ($ENV{HTTP_COOKIE}||'') =~ /dkey=$dkey/) - and open $file,'<',"$file/download") + and open $file,'<',"$file/download") { - $_ = <$file> || ''; + my $d1 = <$file> || ''; # first download + chomp $d1; close $file; - chomp; if ($ra) { # allow downloads from same ip - $_ = '' if /\Q$ra/; + $d1 = '' if $d1 =~ /\Q$ra/; # allow downloads from sender ip - $_ = '' if (readlink("$file/ip")||'') eq $ra; + $d1 = '' if (readlink("$file/ip")||'') eq $ra; } - if ($_) { - s/(.+) ([\w.:]+)$/by $2 at $1/; + if ($d1 and $d1 =~ s/(.+) ([\w.:]+)$/$2 at $1/) { $file = filename($file); - http_die("$file has already been downloaded $_"); + http_die("$file has already been downloaded by $d1"); } } $sb = sendfile($file,$seek,$stop); @@ -587,14 +587,14 @@ debuglog(sprintf("%s %s %d %d %d", isodate(time),$file,$sb||0,$seek,-s $data||0)); if ($sb+$seek == -s $data) { - + # note successfull download $download = "$file/download"; if (open $download,'>>',$download) { printf {$download} "%s %s\n",isodate(time),$ENV{REMOTE_ADDR}; close $download; } - + # delete file after grace period if ($autodelete eq 'YES') { $grace_time = 60 unless defined $grace_time; @@ -613,26 +613,26 @@ if ($sb+$seek == -s $data) { close $error; } } - + } exit; - + sub sendfile { my ($file,$seek,$stop) = @_; my ($filename,$size,$total_size,$fileid,$filetype); my ($data,$download,$header,$buf,$range,$s,$b,$t0); my $type = ''; - + # swap to and from for special senders, see fup storage swap! $file =~ s:^(_?anonymous_.*)/(anonymous.*)/:$2/$1/:; $file =~ s:^(_?fexmail_.*)/(fexmail.*)/:$2/$1/:; - + $data = $file.'/data'; $download = $file.'/download'; $header = $file.'/header'; - + # fallback defaults, should be set later with better values $filename = filename($file); $total_size = -s $data || 0; @@ -675,12 +675,12 @@ sub sendfile { } } $size = $total_size - $seek - ($stop ? $total_size-$stop-1 : 0); - } elsif ($ENV{REQUEST_METHOD} eq 'HEAD') { + } elsif ($ENV{REQUEST_METHOD} eq 'HEAD') { $size = -s $data || 0; - } else { + } else { http_die("unknown HTTP request method $ENV{REQUEST_METHOD}"); } - + # read MIME entity header (what the client said) if (open $header,'<',$header) { while (<$header>) { @@ -692,9 +692,9 @@ sub sendfile { close $header; $type =~ s/\s//g; } - + $fileid = readlink "$file/id" || ''; - + # determine own MIME entity header for download my $mime = $file; $mime =~ s:/.*:/\@MIME:; @@ -717,7 +717,7 @@ sub sendfile { } # reset to default MIME type else { $type = 'application/octet-stream' } - + # HTML is not allowed for security reasons! (embedded javascript, etc) $type =~ s/html/plain/i; @@ -747,7 +747,7 @@ sub sendfile { } nvt_print(''); } else { - # another stupid IE bug-workaround + # another stupid IE bug-workaround # http://drupal.org/node/163445 # http://support.microsoft.com/kb/323308 if ($http_client =~ /MSIE/ and not $nowarning) { @@ -813,7 +813,7 @@ sub sendfile { # control back to fexsrv for further HTTP handling &reexec; } - + if ($ENV{REQUEST_METHOD} eq 'GET') { if (@throttle) { @@ -829,7 +829,7 @@ sub sendfile { $bwl = $limit; last; } - } + } # throttle e-mail address? else { # allow wildcard *, but not regexps @@ -843,7 +843,7 @@ sub sendfile { } } } - + foreach my $sig (keys %SIG) { local $SIG{$sig} = \&sigexit } local $SIG{ALRM} = sub { die "TIMEOUT\n" }; @@ -859,7 +859,7 @@ sub sendfile { $b = $size-$s; $buf = substr($buf,0,$b) } - $s += $b; + $s += $b; alarm($timeout*10); syswrite STDOUT,$buf or last; # client still alive? if ($bwl) { @@ -867,14 +867,14 @@ sub sendfile { sleep 1 while $s/(time-$t0||1)/1024 > $bwl; } } - + close $data; alarm(0); - + fdlog($log,$file,$s,$size); } close $download; - + return $s; } @@ -884,13 +884,13 @@ sub sendsize { my ($file,$upload,$to,$from,$dkey); my $size = 0; local $_; - + $path =~ s:^/::; ($to,$from,$file) = split('/',$path); $to =~ s/,.*//; $to = lc $to; $from = lc $from; - + # swap to and from for special senders, see fup storage swap! ($from,$to) = ($to,$from) if $from =~ /^(fexmail|anonymous)/; @@ -905,7 +905,7 @@ sub sendsize { if ($to eq '*' and $fileid) { foreach my $fd (glob "*/$from/$file") { - if (-f "$fd/data" + if (-f "$fd/data" and -l "$fd/id" and readlink "$fd/id" eq $fileid and $dkey = readlink "$fd/dkey") { $to = $fd; @@ -929,12 +929,12 @@ sub sendsize { } close $AB; } - + if (-f "$to/$from/$file/data") { $dkey = readlink "$to/$from/$file/dkey"; $fkey = slurp("$to/$from/$file/filename")||$file; } - + $upload = -s "$to/$from/$file/upload" || -s "$to/$from/$file/data" || 0; $size = readlink "$to/$from/$file/size" || 0; $fileid = readlink "$to/$from/$file/id" || ''; @@ -1000,11 +1000,11 @@ sub check_auth { if ($path =~ m:(.+)/(.+)/(.+):) { ($to,$from,$file) = ($1,$2,$3); - } elsif ($path =~ m:(.+)/(.+):) { + } elsif ($path =~ m:(.+)/(.+):) { ($dkey,$file) = ($1,$2); $path = readlink "$dkeydir/$dkey" or http_die('no such file'); (undef,$to,$from,$file) = split('/',$path); - } else { + } else { http_die("wrong URL format for download"); } @@ -1028,15 +1028,15 @@ sub check_auth { debuglog("$user mismatch: id=$id, auth=$auth"); &require_auth; } - } + } # check for sub user elsif (open $idf,'<',"$from/\@SUBUSER") { while (<$idf>) { chomp; s/#.*//; ($subuser,$subid) = split ':'; - if ($subid and $subid eq $auth - and ($user eq $subuser + if ($subid and $subid eq $auth + and ($user eq $subuser or $subuser eq '*@*' or $subuser =~ /^\*\@(.+)/ and $user =~ /\@\Q$1\E$/i or $subuser =~ /(.+)\@\*$/ and $user =~ /^\Q$1\E\@/i)) { @@ -1053,7 +1053,7 @@ sub check_auth { debuglog("no $to/@ and no $from/@"); &require_auth; } - + } @@ -1070,7 +1070,7 @@ sub check_captive { sub sigexit { my ($sig) = @_; my $msg; - + $msg = @_ ? "@_" : '???'; $msg =~ s/\n/ /g; $msg =~ s/\s+$//;