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