#!/usr/bin/perl -Tw
use strict;
$|++;
$ENV{PATH} = "/bin:/usr/bin";

## do not run this under Apache::Registry (nested subroutines abound)

## config

my $DIR = "/home/merlyn/Web/RestrictToList";
my $ADMIN_EMAIL = 'webmaster@stonehenge.comm';
my $ADMIN_HUMAN = 'Randal L. Schwartz';

## end config

use CGI qw(:all);
use IO::File;

print
  header, start_html("Web access request"), h1("Web access request");

eval {                          # death if unexpected things happen
  connect_to_database();
  my $message = handle_confirm_request() || handle_form_response();
  if ($message =~ /^FORM:\s+(.*)/s) {
    show_form($1);
  } else {
    print p($message);
  }
};
if ($@) {
  warn $@;                      # to web error log
  print
    h1("An internal error has occurred"),
    p("Please contact me at once, and describe what you did.");
}

print
  h1("If you have any questions..."),
  p("Please contact me at", a({href => "mailto:$ADMIN_EMAIL"}, $ADMIN_EMAIL)),
  end_html;

exit 0;

## only subroutines from here down

sub show_form {
  my $message = shift;

  print
    hr, p($message), start_form,
    table({cellspacing => 0, cellpadding => 2, border => 1},
          Tr(th("Your email address"),
             td(textfield(-name => 'email', -size => 50)),
             td("just the USER\@HOSTNAME.COM part, please")),
          Tr(th("Your preferred username"),
             td(textfield(-name => 'username', -size => 50)),
             td("letters and digits only, at least 5 characters")),
          Tr(th("Your preferred password"),
             td(password_field(-name => 'password', -size => 50)),
             td("at least 5 characters")),
         ),
    submit, hidden('realm'), end_form, hr;
}

sub handle_form_response {
  my $form_email = param('email')
    or return "FORM: Please give your email address.";
  my $info = info_for_email($form_email)
    or return "FORM: I don't recognize that email address, try again.";
  if (my $user = $info->{user}) {
    if (my $password = $info->{password}) {
      if ($password =~ /-/) {   # needs to be verified
        return "You need to check your email for further instructions.";
      }
    }
    return "You are already registered!";
  }
  ## OK, it's a new user with a good email - let's make a login
  my $form_user = param('username')
    or return "FORM: Please give an access username for $form_email.";
  $form_user =~ /^\w{5,20}$/
    or return "FORM: Please use 5 to 20 letters or digits in the username.";
  seen_user($form_user)
    and return "FORM: Sorry, that username is taken. Try another.";
  my $form_password = param('password')
    or return "FORM: Please give a password for $form_user.";
  length($form_password) >= 5
    or return "FORM: Please use at least 5 characters in the password.";
  return add_user($form_email, $form_user, $form_password);
}

sub add_user {
  my ($email, $user, $password) = @_;
  
  require Digest::MD5;
  my $hexhash = Digest::MD5::md5_hex($$, time, "sekret kode",
                                     unpack "%L*", `ps axww`);
  update_info_for_email($email, $user,
                        crypt($password, $hexhash) . "-$hexhash");
  return send_email($email, $hexhash); # DEBUG
}

sub send_email {
  my ($email, $hexhash) = @_;

  my $confirm_url = url()."?realm=".get_realm()."&verify=$hexhash";

  require Net::SMTP;
  my $mail = Net::SMTP->new('localhost') or die "Cannot open mail: $@/$!";
  $mail->mail($ADMIN_EMAIL);
  $mail->to($email);
  $mail->data(<<END);
To: $email
From: "$ADMIN_HUMAN" <$ADMIN_EMAIL>
Subject: confirming your web access request (PLEASE READ)

Please visit the following URL:
<URL:$confirm_url>

If the link above is not a clickable link, visit this location:

  $confirm_url

Please copy the link into your web browser's "location" or "URL"
field carefully.

If you have any questions, please reply to this email.

Thank you,
$ADMIN_HUMAN <$ADMIN_EMAIL>
END
  
  return "Look for email sent to ".tt($email)." for further instructions.";
}

sub handle_confirm_request {
  my $form_verify = param('verify') or return;
  if (my $email_from_hexhash = seen_hexhash($form_verify)) {
    my ($email, $keys, $user, $encrypted_password) =
      @{info_for_email($email_from_hexhash)}{qw(email keys user pw)};
    $encrypted_password =~ s/-.*//;
    update_info_for_email($email, $user, $encrypted_password);
    return "Your access has been verified!";
  }
  return "Please be sure to copy the URL very carefully from the email.";
}

BEGIN {                         # realm holder
  my $realm;

  sub get_realm {
    return $realm if $realm;
    $realm = param('realm') or die "Missing Realm";
    $realm =~ tr/A-Za-z0-9//cd;
    $realm =~ /(\w+)/ or die "empty realm";
    return $realm = $1;         # untaint
  }
}

BEGIN {                         # database things
  my ($filename, $db_handle);
  my (@data, %info_for, %seen_user, %seen_hexhash);

  sub connect_to_database {
    $filename = "$DIR/".get_realm();
    {
      my $h = IO::File->new("< $filename") or die "cannot open $filename: $!";
      flock($h, 2);
      ## because this file might be renamed underneath us:
      my @handle_stat = stat $h;
      my @file_stat = stat $filename;
      redo if $handle_stat[0] != $file_stat[0];
      redo if $handle_stat[1] != $file_stat[1];
      $db_handle = $h;          # fall out
    }
    for (@data = <$db_handle>) {
      my ($email, $keys, $user, $pw) = split;
      for ($info_for{lc $email} ||= {}) {
        $_->{email} = $email;
        $_->{keys} = $keys;
        $_->{user} = $user if $user;
        $_->{pw} = $pw if $pw;
      }
      $seen_user{$user}++ if $user;
      $seen_hexhash{$1} = $email if $pw and $pw =~ /-(.*)/;
    }
  }

  sub info_for_email {
    my $email = shift;

    $info_for{lc $email};
  }

  sub update_info_for_email {
    my ($email, $user, $encrypted_password) = @_;

    for ($info_for{lc $email}) {
      defined $_ or die "shouldn't happen - undef lc $email info";
      $_->{user} = $user;
      $_->{pw} = $encrypted_password;
    }
    my $tmp = "$filename.tmp";
    {
      my $h = IO::File->new("> $tmp") or die "Cannot create $tmp: $!";
      chmod +(stat($db_handle))[2], $tmp or warn "Cannot chmod $tmp: $!";
      for my $email (sort keys %info_for) {
        print $h join(" ", map {
          exists $info_for{$email}{$_} ? $info_for{$email}{$_} : ()
        } qw(email keys user pw)), "\n";
      }
    }
    rename $tmp, $filename or warn "Cannot rename $tmp to $filename: $!";
  }

  sub seen_user {
    $seen_user{+shift} ? 1 : 0;
  }

  sub seen_hexhash {
    $seen_hexhash{+shift};      # returns email key
  }
}