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