]> git.treefish.org Git - fex.git/blob - cgi-bin/rup
Original release 20150826
[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 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 }