cgi-bin/rup

   1 #!/usr/bin/perl -wT
   2
   3 # FEX CGI for redirect uploaded files
   4 #
   5 # Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
   6 #
   7
   8 BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 }
   9
  10 use utf8;
  11 use Fcntl       qw(:flock :seek :mode);
  12 use Digest::MD5 qw(md5_hex);
  13
  14 # add fex lib
  15 (our $FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
  16 die "$0: no $FEXLIB\n" unless -d $FEXLIB;
  17
  18 our ($keep_default,$dkeydir,$akeydir,$mdomain,@logdir,$fra);
  19 our $akey = '';
  20
  21 # load common code, local config : $HOME/lib/fex.ph
  22 require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";
  23
  24 our $error = 'F*EX redirect ERROR';
  25
  26 chdir $spooldir or die "$spooldir - $!\n";
  27
  28 $from = $id = $oto = $nto = $file = '';
  29
  30 # look for CGI parameters
  31 our %PARAM;
  32 &parse_parameters;
  33 foreach my $v (keys %PARAM) {
  34   my $vv = $PARAM{$v};
  35   $vv =~ s/[<>\'\`\"\000-\037]//g;
  36   if ($v =~ /^akey$/i and $vv =~ /^(\w+)$/) {
  37     $akey = $1;
  38   } elsif ($v =~ /^(from|user)$/i) {
  39     $from = normalize_address($vv);
  40     $from .= '@'.$mdomain if $mdomain and $from !~ /@/;
  41   } elsif ($v =~ /^id$/i) {
  42     $id = despace($vv);
  43   } elsif ($v =~ /^file$/i) {
  44     $vv =~ s:/:_:g;
  45     $file = untaint(normalize($vv));
  46   } elsif ($v =~ /^oto$/i) {
  47     $oto = normalize_address($vv);
  48     $oto .= '@'.$mdomain if $mdomain and $oto !~ /@/;
  49   } elsif ($v =~ /^nto$/i) {
  50     $nto = normalize_address($vv);
  51   }
  52 }
  53
  54 if ($akey and not $from) {
  55   if (open $akey,'<',"$akeydir/$akey/@" and $id = getline($akey)) {
  56     close $akey;
  57     $from = readlink "$akeydir/$akey";
  58     $from =~ s:.*/::;
  59     $from = untaint($from);
  60     if ($akey ne md5_hex("$from:$id")) {
  61       $from = $id = '';
  62     }
  63   }
  64 }
  65
  66 if ($from and -s "$from/\@ALLOWED_RECIPIENTS") {
  67   http_die("You are a restricted user");
  68 }
  69
  70 if ($from and $id) {
  71   open F,'<',"$from/@" or http_die("wrong user or auth-ID");
  72   chomp($rid = <F>);
  73   close F;
  74   http_die("wrong user or auth-ID") if $id ne $rid;
  75   unless ($akey) {
  76     $akey = untaint(md5_hex("$from:$id"));
  77     unlink "$akeydir/$akey";
  78     symlink "../$from","$akeydir/$akey";
  79   }
  80 } else {
  81   http_die("wrong user or auth-ID");
  82 }
  83
  84 if ($oto and not glob("$oto/$from/*")) {
  85   http_die("$oto has no no files in spool from you ($from)");
  86 }
  87
  88 # display HTML form and request user data
  89 unless ($from and $id and $file and $oto and $nto) {
  90   $head = "$ENV{SERVER_NAME} F*EX redirect";
  91   http_header("200 OK");
  92   print html_header($head);
  93   pq(qq(
  94     '<form action="$ENV{SCRIPT_NAME}" method="post"'
  95     ' accept-charset="UTF-8" enctype="multipart/form-data">'
  96     '  <table>'
  97   ));
  98   if ($akey) {
  99     print "<input type=\"hidden\" name=\"akey\"   value=\"$akey\">\n";
 100   } else {
 101     pq(qq(
 102       '    <tr><td>sender:'
 103       '        <td><input type="text"     name="from" size="80" value="$from"></tr>'
 104       '    <tr><td>auth-ID:'
 105       '        <td><input type="password" name="id"   size="16" value="$id"></tr>'
 106     ));
 107   }
 108   if ($oto) {
 109     pq(qq(
 110       '    <tr><td>old (wrong) recipient:<td>$oto</tr>'
 111       '        <input type="hidden" name="oto"   value="$oto">'
 112     ));
 113   } else {
 114     pq(qq(
 115       '    <tr><td>old (wrong) recipient:'
 116       '        <td><input type="text"      name="oto"  size="80" value="$oto"></tr>'
 117     ));
 118   }
 119   if ($from and $oto) {
 120     pq(qq(
 121       '    <tr><td>new recipient:'
 122       '        <td><input type="text"      name="nto"  size="80" value="$nto"></tr>'
 123       '    <tr><td>filename: <td><select name="file" size="1">'
 124     ));
 125     if ($file) {
 126       print "\t<option>$file</option>\n";
 127     } else {
 128       foreach my $file (glob "$oto/$from/*/data") {
 129         next if $file =~ m:/STDFEX/:;
 130         $file =~ s:/data$::;
 131         if ($filename = filename($file)) {
 132           print "\t<option>$filename</option>\n";
 133         }
 134       }
 135     }
 136     print "    </tr>\n";
 137   }
 138   pq(qq(
 139     '  </table>'
 140     '  <p>'
 141     '  <input type="submit" value="submit">'
 142     '</form>'
 143     <p>
 144     '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 145     '</body></html>'
 146   ));
 147   exit;
 148 }
 149
 150 if ($nto) {
 151
 152   # read aliases from address book
 153   if (open my $AB,'<',"$from/\@ADDRESS_BOOK") {
 154     while (<$AB>) {
 155       s/#.*//;
 156       $_ = lc $_;
 157       if (s/^\s*(\S+)[=\s]+(\S+)//) {
 158         my ($alias,$address) = ($1,$2);
 159         if ($nto eq $alias) {
 160           $nto = $address;
 161           last;
 162         }
 163       }
 164     }
 165     close $AB;
 166   }
 167
 168   $nto .= '@'.$mdomain if $mdomain and $nto !~ /@/ and $nto =~ /\w/;
 169   checkaddress($nto) or http_die("$nto is not a valid e-mail address");
 170 } else {
 171   http_die("no new recipient given");
 172 }
 173
 174 if ($oto and $nto and $oto eq $nto) {
 175   http_die("new recipient must be other than old recipient");
 176 }
 177
 178 $fkey = urlencode($file);
 179 unless (-s "$oto/$from/$fkey/data") {
 180   http_die("no upload data found for $file for $oto");
 181 }
 182
 183 if (not -e "$oto/$from/$fkey/data") {
 184   if (my $download = slurp("$oto/$from/$fkey/download")) {
 185     chomp $download;
 186     http_die("$file already downloaded by $download");
 187   }
 188   http_die("$file has gone");
 189 }
 190
 191 mkdirp("$nto/$from");
 192 rmrf("$nto/$from/$fkey");
 193
 194 if (rename "$oto/$from/$fkey","$nto/$from/$fkey") {
 195   mkdirp("$oto/$from/$fkey");
 196   if (open $fkey,'>',"$oto/$from/$fkey/error") {
 197     print {$fkey} "$from has removed $file\n";
 198     close $fkey;
 199   }
 200   unlink "$nto/$from/$fkey/dkey";
 201   unlink "$nto/$from/$fkey/notify";
 202   unlink "$nto/$from/$fkey/error";
 203   unlink "$nto/$from/$fkey/download";
 204   if (slurp("$oto/$from/$fkey/comment")||'' =~ /NOMAIL/) {
 205     unlink "$nto/$from/$fkey/comment";
 206   }
 207   $dkey = randstring(8);
 208   symlink $dkey,"$nto/$from/$fkey/dkey";
 209   symlink "../$nto/$from/$fkey","$dkeydir/$dkey";
 210   $filename = filename("$nto/$from/$fkey") || $fkey;
 211   notify_locale($dkey,'new');
 212   ruplog("$oto/$from/$fkey ==> $nto");
 213   http_header("200 OK");
 214   print html_header('F*EX redirect');
 215   pq(qq(
 216     '<h3>F*EX redirect</h3>'
 217     'notification of file upload \"$filename\" sent to $nto'
 218     '<p>'
 219     '<a href="/foc?akey=$akey">back to F*EX operation control</a>'
 220     '</body></html>'
 221   ));
 222 } else {
 223   http_die("redirect $nto/$from/$fkey failed : $!")
 224 }
 225
 226 exit;
 227
 228
 229 sub normalize_address {
 230   local $_ = shift;
 231   s/[<>;,\s\|\/\'\`\"\000-\037]//g;
 232   $_ = untaint($_);
 233 }
 234
 235
 236 # standard log
 237 sub ruplog {
 238   my $msg = "@_";
 239
 240   $msg =~ s/\n/ /g;
 241   $msg =~ s/\s+$//;
 242   $msg = sprintf "%s [%s_%s] (%s) %s\n",
 243                  isodate(time),$$,$ENV{REQUESTCOUNT},$fra,$msg;
 244
 245   foreach my $log (@logdir) {
 246     if (open $log,'>>',"$log/rup.log") {
 247       flock $log,LOCK_EX;
 248       seek $log,0,SEEK_END;
 249       printf {$log} $msg;
 250       close $log;
 251     }
 252   }
 253 }