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