]> git.treefish.org Git - fex.git/blob - cgi-bin/rup
10a78b6e771d67a5e89ba8133c617240733b253a
[fex.git] / 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 use Fcntl       qw(:flock :seek :mode);
9 use CGI         qw(:standard);
10 use CGI::Carp   qw(fatalsToBrowser);
11 use Fcntl       qw(:flock);
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 my $log = "$logdir/rup.log";
29
30 $from = $id = $oto = $nto = $file = '';
31
32 # look for CGI parameters
33 foreach my $v (param) {
34   $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   
243   if (open $log,'>>',$log) {
244     flock $log,LOCK_EX;
245     seek $log,0,SEEK_END;
246     printf {$log} "%s [%s_%s] (%s) %s\n",
247                   isodate(time),$$,$ENV{REQUESTCOUNT},$fra,$msg;
248     close $log;
249   }
250 }