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 }