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