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 }