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