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 }