]> git.treefish.org Git - fex.git/blob - cgi-bin/fur
3d91f55878fba93e29eb35fa66341297cc0aba89
[fex.git] / cgi-bin / fur
1 #!/usr/bin/perl -wT
2
3 # FEX CGI for user registration
4 #
5 # Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
6 #
7
8 use CGI         qw(:standard);
9 use CGI::Carp   qw(fatalsToBrowser);
10 use Fcntl       qw(:flock :seek :mode);
11
12 $CGI::LIST_CONTEXT_WARN = 0;
13 $CGI::LIST_CONTEXT_WARN = 0;
14
15 # import from fex.ph
16 our (@local_hosts,@local_domains,@local_rhosts,@local_rdomains);
17 our (@registration_hosts,@registration_domains);
18 our ($usage_conditions);
19
20 # import from fex.pp
21 our ($mdomain,$logdir,$spooldir,$fra,$hostname,$sendmail,$admin,$bcc);
22
23 our $error = "F*EX user registration ERROR";
24
25 my $ra = $ENV{REMOTE_ADDR}||0;
26
27 my ($CASE,$ESAC);
28
29 # add fex lib
30 (our $FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
31 die "$0: no $FEXLIB\n" unless -d $FEXLIB;
32
33 # load common code, local config: $HOME/lib/fex.ph
34 require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";
35
36 my $log = "$logdir/fur.log";
37 my $head = "$ENV{SERVER_NAME} F*EX user registration";
38
39 chdir $spooldir or die "$spooldir - $!\n";
40
41 my $user = my $id = my $verify = '';
42
43 &check_maint;
44
45 unless (@local_domains or @local_rdomains) {
46   html_error($error,
47     "No domains for registrations are defined.",
48     "Contact $ENV{SERVER_ADMIN} for details."
49   );
50 }
51
52 # look for CGI parameters
53 foreach my $v (param) {
54   my $vv = despace(param($v));
55   debuglog("Param: $v=\"$vv\"");
56   $CASE =
57     $v =~ /^user$/i     ? $user         = normalize_address($vv):
58     $v =~ /^exuser$/i   ? $exuser       = normalize_address($vv):
59     $v =~ /^demouser$/i ? $demouser     = normalize_address($vv):
60     $v =~ /^verify$/i   ? $verify       = lc(checkchars('URL-parameter',$vv)):
61     $v =~ /^confirm$/i  ? $confirm      = checkchars('URL-parameter',$vv):
62     $v =~ /^domain$/i   ? $domain       = lc(checkchars('URL-parameter',$vv)):
63   $ESAC;
64 }
65
66 if ($confirm) {
67   if ($confirm =~ /^(\w+)$/i) {
68     $confirm = $1;
69   } else {
70     http_die("illegal registration key");
71   }
72   open $confirm,"<.reg/$confirm" or http_die("no registration key $confirm");
73   $user = untaint(getline($confirm));
74   $id   = getline($confirm);
75   close $confirm;
76   # unlink ".reg/$confirm";
77   unless ($user and $id) {
78     http_die("no registration data for key $confirm");
79   }
80   unless (-f "$user/.auto") {
81     http_die("registration expired");
82   }
83   # if (-f "$user/@") { http_die("$user is already activated") }
84   open $user,'>',"$user/@" or http_die("open $user/@ - $!\n");
85   print {$user} $id,"\n";  
86   close $user or http_die("close $user/@ - $!\n");
87   
88   http_header("200 OK");
89   print html_header($head);
90   my $url = "$ENV{PROTO}://$ENV{HTTP_HOST}/fup/" . b64("from=$user&id=$id");
91   pq(qq(
92     '<h3>Your registration was successful. Your new F*EX account is:</h3>'
93     '<p>'
94     '<code><a href="$url">$url</a></code>'
95     '<p>'
96     '(bookmark this URL!)'
97     '<p>'
98     'or you can use:'
99     '<p>'
100     '<table>
101     '  <tr><td>URL:<td><code><b>$ENV{PROTO}://$ENV{HTTP_HOST}/fup/</code></b></tr>'
102     '  <tr><td>Sender:<td><code><b>$user</code></b></tr>'
103     '  <tr><td>auth-ID:<td><code><b>$id</code></b></tr>'
104     '</table>
105     '</body></html>'
106   ));
107   furlog("confirm: account $user created");
108   exit;
109 }
110
111
112 unless ($user or $exuser or $demouser) {
113   http_header("200 OK");
114   print html_header($head);
115   pq(qq(
116     '<form action="$ENV{SCRIPT_NAME}"'
117     '      method="post"'
118     '      accept-charset="UTF-8"'
119     '      enctype="multipart/form-data">'
120   ));
121   
122   if (@local_domains and @local_hosts and ipin($ra,@local_hosts)) {
123     $reg = $ra;
124     if (grep(/\*/,@local_domains)) {
125       pq(qq(
126         '  new user (may send to internal or external users):<br>'
127         '  <input type="text" name="user" size="80" value="$user">'
128         '<p>'
129         '  allowed domains are:'
130         '<pre>'
131       ));
132       foreach my $ld (@local_domains) {
133         print "  $ld\n";
134       }
135       print "</pre>\n";
136     } else {
137       if ($mdomain and not grep /^\Q$mdomain\E$/i,@local_domains) {
138         unshift @local_domains,$mdomain;
139       }
140       my @mydomains = map { "\t<option>$_</option>\n" } @local_domains;
141       pq(qq(
142         '  new user (may send to internal or external users):<br>'
143         '  <input type="text" name="user" size="40" value="$user">\@<select name="domain" size="1">@mydomains</select>'
144       ));
145     }
146   }
147   
148   if (@local_rdomains and @local_rhosts and 
149       (not @registration_hosts or ipin($ra,@registration_hosts))) {
150     print "   <p>or<p>\n" if $reg;
151     $reg = $ra;
152     pq(qq(
153       '  new external user (may send only to internal users):<br>'
154       '  <input type="text" name="exuser" size="80">'
155       '  <p>'
156     ));
157   }
158   
159   if (@demo) {
160     print "   <p>or<p>\n" if $reg;
161     $reg = $ra;
162     local $_ = sprintf "with %d MB quota and %d day%s account life time",
163       @demo,$demo[1]>1 ? 's' : '';
164     pq(qq(
165       '  new demo user ($_):<br>'
166       '  <input type="text" name="demouser" size="80">'
167       '  <p>'
168     ));
169   }
170   
171   if ($reg) {
172     pq(qq(
173       '  <p>'
174       '  you must enter your e-mail address and <input type="submit" value="submit">'
175       '</form>'
176       '<p>'
177     ));
178     if (@local_rdomains) {
179       pq(qq(
180         '<p><hr><p>'
181         'internal domains are:'
182         '<pre>'
183       ));
184       foreach my $lrd (@local_rdomains) {
185         print "  $lrd\n";
186       }
187     }
188     pq(qq(
189       '</pre>'
190       '<p><hr><p>'
191       '<a href="http://fex.rus.uni-stuttgart.de/users.html">User types overview</a>'
192       '</body></html>'
193     ));
194   } else {
195     html_error($error,
196       "Registrations from your host ($ra) are not allowed.",
197       "Contact $ENV{SERVER_ADMIN} for details."
198     );
199   }
200   exit;
201 }
202
203 if ($exuser) {
204   unless (@local_rdomains) {
205     http_die("no \@local_rdomains");
206   }
207   if (@registration_hosts and not ipin($ra,@registration_hosts)) {
208     html_error($error,
209       "Registrations from your host ($ra) are not allowed.",
210       "Contact $ENV{SERVER_ADMIN} for details."
211     );
212   }
213   if ($exuser =~ /\@(.+)/) {
214     my $exd = $1;
215     if (@registration_domains and
216         not grep /^\Q$exd\E$/i,@registration_domains) {
217       html_error($error,
218         "Your domain <code>$exd</code> is not allowed for registration.",
219         "Contact $ENV{SERVER_ADMIN} for details."
220       );
221     }
222   } else {
223     html_error($error,"<code>$exuser</code> is not an email address");
224   }
225   $user = $exuser;
226 } elsif ($demouser) {
227   $user = $demouser;
228 } elsif ($user) {
229   unless (@local_domains) {
230     html_error($error,
231       "No local domains for registration are defined.",
232       "Contact $ENV{SERVER_ADMIN} for details."
233     );
234   }
235   my $mydomains = join('|',@local_domains);
236   $mydomains =~ s/\./\\./g;
237   $mydomains =~ s/\*/.*/g;
238   $mydomains .= "|$mdomain" if $mdomain;
239   $user .= '@'.$domain if $domain and $user !~ /@/;
240   # $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
241   
242   unless (@local_hosts and ipin($ra,@local_hosts)) {
243     html_error($error,
244       "Registrations from your host ($ra) are not allowed.",
245       "Contact $ENV{SERVER_ADMIN} for details."
246     );
247   }
248   if ("@local_domains" ne "*" and $user !~ /\@($mydomains)$/i) {
249     html_error($error,
250       "Illegal domain for username.",
251       "Contact $ENV{SERVER_ADMIN} for details."
252     );
253   }
254 } else {
255   html_error($error,"No user type found.");
256 }
257
258 unless (checkforbidden($user)) {
259   html_error($error,"<code>$user</code> is not allowed");
260 }
261 unless (checkaddress($user)) {
262   html_error($error,"<code>$user</code> is not a valid e-mail address");
263 }
264 $user = untaint($user);
265
266 if (-f "$user/@") {
267   html_error(
268     $error,
269     "you are already registered".
270     " (<a href=\"/fup?from=$user&ID_forgotten=1\">I have lost my auth-ID</a>)"
271   ); 
272 }
273
274 unless (-d $user) {
275   mkdir $user,0770 or http_die("mkdir $user - $!\n");
276 }
277
278 if ($exuser) {
279   my $rf;
280   # recipients e-mail address restrictions
281   $rf = "$exuser/\@ALLOWED_RECIPIENTS";
282   open $rf,'>',$rf or http_die("cannot write $rf - $!\n");
283   print {$rf} "\@LOCAL_RDOMAINS\n";
284   print {$rf} "# See also file \@ALLOWED_RHOSTS\n";
285   close $rf;
286   # recipients ip restrictions
287   $rf = "$exuser/\@ALLOWED_RHOSTS";
288   open $rf,'>',$rf or http_die("cannot write $rf - $!\n");
289   print {$rf} "\@LOCAL_RHOSTS\n";
290   close $rf;
291   if (open $user,'>',"$user/.auto") {
292     print {$user} "fur:external\n";  
293     close $user;
294   }
295 } elsif ($demouser) {
296   my $quota = "$demouser/\@QUOTA";
297   open $quota,'>',$quota or http_die("cannot write $quota - $!\n");
298   printf {$quota} "recipient:%d\n",$demo[0];
299   printf {$quota} "sender:%d\n",$demo[0];
300   close $quota;
301   if (open $user,'>',"$user/.auto") {
302     print {$user} "fur:demo\n";  
303     close $user;
304   }
305   open $demouser,'>',"$demouser/.demo" and close $demouser;
306 } else {
307   if (open $user,'>',"$user/.auto") {
308     print {$user} "fur:internal\n";  
309     close $user;
310   }
311 }
312
313 $id = randstring(6);
314
315 if ("@local_domains" eq "*") {
316   open $id,'>',"$user/@" or http_die("open $user/@ - $!\n");
317   print {$id} $id,"\n";  
318   close $id or http_die("close $user/@ - $!\n");
319   http_header("200 OK");
320   print html_header($head);
321   $uid = "from=$user&id=$id";
322   $b64 = b64($uid);
323   pq(qq(
324     'Account created:'
325     '<pre>'
326     '$ENV{PROTO}://$ENV{HTTP_HOST}/fup?$uid'
327     '$ENV{PROTO}://$ENV{HTTP_HOST}/fup/$b64'
328     '</pre>'
329     '</body></html>'
330   ));
331   exit;
332 }
333
334 # from fexsend
335 if ($verify eq 'no') {
336   open $id,'>',"$user/@" or http_die("open $user/@ - $!\n");
337   print {$id} $id,"\n";  
338   close $id or http_die("close $user/@ - $!\n");
339   http_header("200 OK",'Content-Type: text/plain');
340   print "$ENV{PROTO}://$ENV{HTTP_HOST}/fup?from=$user&ID=$id\n";
341   furlog("direct: account $user created");
342   if ($bcc and open my $mail,"|$sendmail '$bcc' 2>>$log") {
343     pq($mail,qq(
344       'From: fex'
345       'To: $bcc'
346       'Subject: F*EX user registration'
347       ''
348       '$user has been auto-registrated with verify=no'
349     ));
350     close $mail;
351   } else {
352     furlog("ERROR: cannot run sendmail - $!\n");
353   }
354   exit;
355 }
356
357 unless (-d '.reg') {
358   mkdir '.reg',0770 or http_die("mkdir .reg - $!\n");
359 }
360 $reg = randstring(8);
361 open $reg,'>',".reg/$reg" or http_die("open .reg/$reg - $!\n");
362 print {$reg} $user,"\n",$id,"\n";
363 close $reg or http_die("close .reg/$reg - $!\n");
364
365 open my $mail,'|-',$sendmail,$user,$bcc
366   or http_die("cannot start sendmail - $!\n");
367 pq($mail,qq(
368   'From: $admin'
369   'To: $user'
370   'Subject: F*EX user registration request'
371   ''
372   'To activate your new F*EX account go to this URL:'
373   ''
374   '$ENV{PROTO}://$ENV{HTTP_HOST}/fur?confirm=$reg'
375   ''
376 ));
377 if ($usage_conditions and open $usage_conditions,$usage_conditions) {
378   print {$mail} "The conditions of usage are:\n\n";
379   print {$mail} $_ while <$usage_conditions>;
380   close $usage_conditions;
381 }
382 close $mail or http_die("cannot send mail - $!\n");
383
384 http_header("200 OK");
385 print html_header($head);
386 print "confirmation e-mail has been sent to <code>$user</code>\n";
387 print "</body></html>\n"; 
388 furlog("confirmation request mailed to $user");
389 exit;
390
391
392 # standard log
393 sub furlog {
394   my $msg = "@_";
395   
396   $msg =~ s/\n/ /g;
397   $msg =~ s/\s+$//;
398   
399   if (open $log,'>>',$log) {
400     flock $log,LOCK_EX;
401     seek $log,0,SEEK_END;
402     printf {$log} "%s [%s_%s] %s %s\n",
403                   isodate(time),$$,$ENV{REQUESTCOUNT},$fra,$msg;
404     close $log;
405   }
406 }
407
408 sub normalize_address {
409   my $a = shift;
410
411   $a = lc(normalize(despace($a)));
412   checkchars('address',$a);
413   $a =~ s:/:_:g;
414   $a =~ s:^\.:_:;
415   return untaint($a);
416 }