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