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