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