1     #!/usr/bin/perl -Tw
2     use strict;
3     $|++;
4     $ENV{PATH} = "/bin:/usr/bin";
5     
6     ## do not run this under Apache::Registry 
      ## (nested subroutines abound)
7     
8     ## config
9     
10    my $DIR = "/home/merlyn/Web/RestrictToList";
11    my $ADMIN_EMAIL = 'webmaster@stonehenge.comm';
12    my $ADMIN_HUMAN = 'Randal L. Schwartz';
13    
14    ## end config
15    
16    use CGI qw(:all);
17    use IO::File;
18    
19    print
20      header, start_html("Web access request"), 
        h1("Web access request");
21    
22    eval {                   # death if unexpected things happen
23      connect_to_database();
24      my $message = handle_confirm_request() || handle_form_response();
25      if ($message =~ /^FORM:\s+(.*)/s) {
26        show_form($1);
27      } else {
28        print p($message);
29      }
30    };
31    if ($@) {
32      warn $@;               # to web error log
33      print
34        h1("An internal error has occurred"),
35        p("Please contact me at once, and describe what you did.");
36    }
37    
38    print
39      h1("If you have any questions..."),
40      p("Please contact me at", a({href => "mailto:$ADMIN_EMAIL"}, 
                                     $ADMIN_EMAIL)),
41      end_html;
42    
43    exit 0;
44    
45    ## only subroutines from here down
46    
47    sub show_form {
48      my $message = shift;
49    
50      print
51        hr, p($message), start_form,
52        table({cellspacing => 0, cellpadding => 2, border => 1},
53              Tr(th("Your email address"),
54                 td(textfield(-name => 'email', -size => 50)),
55                 td("just the USER\@HOSTNAME.COM part, please")),
56              Tr(th("Your preferred username"),
57                 td(textfield(-name => 'username', -size => 50)),
58                 td("letters and digits only, at least 5 characters")),
59              Tr(th("Your preferred password"),
60                 td(password_field(-name => 'password', -size => 50)),
61                 td("at least 5 characters")),
62             ),
63        submit, hidden('realm'), end_form, hr;
64    }
65    
66    sub handle_form_response {
67      my $form_email = param('email')
68        or return "FORM: Please give your email address.";
69      my $info = info_for_email($form_email)
70        or return "FORM: I don't recognize that email address, 
                           try again.";
71      if (my $user = $info->{user}) {
72        if (my $password = $info->{password}) {
73          if ($password =~ /-/) {   # needs to be verified
74            return "You need to check your email 
                      for further instructions.";
75          }
76        }
77        return "You are already registered!";
78      }
79      ## OK, it's a new user with a good email - let's make a login
80      my $form_user = param('username')
81        or return "FORM: Please give an access username 
                           for $form_email.";
82      $form_user =~ /^\w{5,20}$/
83        or return "FORM: Please use 5 to 20 letters or digits 
                           in the username.";
84      seen_user($form_user)
85        and return "FORM: Sorry, that username is taken. Try another.";
86      my $form_password = param('password')
87        or return "FORM: Please give a password for $form_user.";
88      length($form_password) >= 5
89        or return "FORM: Please use at least 5 characters 
                           in the password.";
90      return add_user($form_email, $form_user, $form_password);
91    }
92    
93    sub add_user {
94      my ($email, $user, $password) = @_;
95      
96      require Digest::MD5;
97      my $hexhash = Digest::MD5::md5_hex($$, time, "sekret kode",
98                                         unpack "%L*", `ps axww`);
99      update_info_for_email($email, $user,
100                           crypt($password, $hexhash) . "-$hexhash");
101     return send_email($email, $hexhash); # DEBUG
102   }
103   
104   sub send_email {
105     my ($email, $hexhash) = @_;
106   
107     my $confirm_url = url()."?realm=".get_realm()."&verify=$hexhash";
108   
109     require Net::SMTP;
110     my $mail = Net::SMTP->new('localhost') 
                              or die "Cannot open mail: $@/$!";
111     $mail->mail($ADMIN_EMAIL);
112     $mail->to($email);
113     $mail->data(<<END);
114   To: $email
115   From: "$ADMIN_HUMAN" <$ADMIN_EMAIL>
116   Subject: confirming your web access request (PLEASE READ)
117   
118   Please visit the following URL:
119   <URL:$confirm_url>
120   
121   If the link above is not a clickable link, visit this location:
122   
123     $confirm_url
124   
125   Please copy the link into your web browser's "location" or "URL"
126   field carefully.
127   
128   If you have any questions, please reply to this email.
129   
130   Thank you,
131   $ADMIN_HUMAN <$ADMIN_EMAIL>
132   END
133     
134     return "Look for email sent to ".tt($email)." 
                for further instructions.";
135   }
136   
137   sub handle_confirm_request {
138     my $form_verify = param('verify') or return;
139     if (my $email_from_hexhash = seen_hexhash($form_verify)) {
140       my ($email, $keys, $user, $encrypted_password) =
141         @{info_for_email($email_from_hexhash)}
             {qw(email keys user pw)};
142       $encrypted_password =~ s/-.*//;
143       update_info_for_email($email, $user, $encrypted_password);
144       return "Your access has been verified!";
145     }
146     return "Please be sure to copy the URL very carefully 
                from the email.";
147   }
148   
149   BEGIN {                         # realm holder
150     my $realm;
151   
152     sub get_realm {
153       return $realm if $realm;
154       $realm = param('realm') or die "Missing Realm";
155       $realm =~ tr/A-Za-z0-9//cd;
156       $realm =~ /(\w+)/ or die "empty realm";
157       return $realm = $1;         # untaint
158     }
159   }
160   
161   BEGIN {                         # database things
162     my ($filename, $db_handle);
163     my (@data, %info_for, %seen_user, %seen_hexhash);
164   
165     sub connect_to_database {
166       $filename = "$DIR/".get_realm();
167       {
168         my $h = IO::File->new("< $filename") 
                              or die "cannot open $filename: $!";
169         flock($h, 2);
170         ## because this file might be renamed underneath us:
171         my @handle_stat = stat $h;
172         my @file_stat = stat $filename;
173         redo if $handle_stat[0] != $file_stat[0];
174         redo if $handle_stat[1] != $file_stat[1];
175         $db_handle = $h;          # fall out
176       }
177       for (@data = <$db_handle>) {
178         my ($email, $keys, $user, $pw) = split;
179         for ($info_for{lc $email} ||= {}) {
180           $_->{email} = $email;
181           $_->{keys} = $keys;
182           $_->{user} = $user if $user;
183           $_->{pw} = $pw if $pw;
184         }
185         $seen_user{$user}++ if $user;
186         $seen_hexhash{$1} = $email if $pw and $pw =~ /-(.*)/;
187       }
188     }
189   
190     sub info_for_email {
191       my $email = shift;
192   
193       $info_for{lc $email};
194     }
195   
196     sub update_info_for_email {
197       my ($email, $user, $encrypted_password) = @_;
198   
199       for ($info_for{lc $email}) {
200         defined $_ or die "shouldn't happen - undef lc $email info";
201         $_->{user} = $user;
202         $_->{pw} = $encrypted_password;
203       }
204       my $tmp = "$filename.tmp";
205       {
206         my $h = IO::File->new("> $tmp") or die "Cannot create $tmp: $!";
207         chmod +(stat($db_handle))[2], 
                $tmp or warn "Cannot chmod $tmp: $!";
208         for my $email (sort keys %info_for) {
209           print $h join(" ", map {
210             exists $info_for{$email}{$_} ? $info_for{$email}{$_} : ()
211           } qw(email keys user pw)), "\n";
212         }
213       }
214       rename $tmp, $filename or warn "Cannot rename 
                                          $tmp to $filename: $!";
215     }
216   
217     sub seen_user {
218       $seen_user{+shift} ? 1 : 0;
219     }
220   
221     sub seen_hexhash {
222       $seen_hexhash{+shift};      # returns email key
223     }
224   }