File Coverage

script/tinyauth
Criterion Covered Total %
statement 329 365 90.1
branch 100 142 70.4
condition 21 42 50.0
subroutine 78 81 96.3
pod 0 60 0.0
total 528 690 76.5


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             package main;
4              
5 8     8   369977 use 5.005;
  8         30  
  8         312  
6 8     8   40 use strict;
  8         15  
  8         253  
7              
8 8     8   40 use vars qw{$VERSION};
  8         24  
  8         10490  
9             BEGIN {
10 8     8   1293 $VERSION = '0.98';
11             }
12              
13             sub error {
14 0     0   0 print "Content-type: text/plain\n\nError: $_[0]\n";
15 0         0 exit(0);
16             }
17              
18             BEGIN {
19 8     8   19 eval {
20 8         8478 require FindBin;
21 8         9819 require File::Spec;
22 8         37 require Scalar::Util;
23 8         152755 require YAML::Tiny;
24 8         32023 require CGI;
25 8         180359 require Authen::Htpasswd;
26 8         284400 require Email::MIME;
27 8         1359599 require Email::MIME::Creator;
28 8         8870 require Email::Send;
29             };
30 8 50       134427 if ( $@ ) {
31 0         0 error("Failed to load critical module dependency: $@");
32             }
33             }
34              
35             unless ( $ENV{TEST_TINYAUTH} ) {
36             # Create the configuration
37             my $config_file = File::Spec->catfile( $FindBin::Bin, 'tinyauth.conf' );
38             unless ( -f $config_file ) {
39             error("Config file $config_file does not exist");
40             }
41             unless ( -f $config_file ) {
42             error("No read permissions for config file $config_file");
43             }
44              
45             my $config = YAML::Tiny->read( $config_file );
46             unless ( $config ) {
47             error("Failed to load config file at $config_file");
48             }
49              
50             # Create the web application
51             my $application = eval {
52             TinyAuth->new(
53             config => $config,
54             )
55             };
56             unless ( $application ) {
57             error("Failed to create TinyAuth instance: $@");
58             }
59              
60             # Run the instance
61             my $rv = eval { $application->run };
62             unless ( $rv ) {
63             error("Application instance failed to run: $@");
64             }
65              
66             exit(0);
67             }
68              
69              
70              
71              
72              
73             $INC{'TinyAuth.pm'} = __FILE__;
74             #####################################################################
75             # Inline lib/TinyAuth.pm
76             package TinyAuth;
77              
78             =pod
79              
80             =head1 NAME
81              
82             TinyAuth - Extremely light-weight web-based authentication manager
83              
84             =head1 STATUS
85              
86             TinyAuth is currently currently feature-complete and undergoing polishing
87             and testing. Part of this process focuses on naming ("TinyAuth" is just
88             a working codename), reduction of dependencies, improvements to the
89             installer, and other similar tasks.
90              
91             Releases are provided "as is" for the curious, and installation is not
92             recommended for production purposes at this time.
93              
94             =head1 DESCRIPTION
95              
96             B is a light-weight authentication management web application
97             with a focus on usability.
98              
99             It was initially created to assist in managing a subversion repository but
100             also usable for anything where authentication can be run from a F<.htpasswd>
101             file.
102              
103             It provides the basic functionality needed for adding and removing
104             users, and handling password maintenance with as little code and fuss
105             as possible, while still applying robust and correct security practices.
106              
107             It is intended to be extremely easy to install and set up, even on shared
108             hosting accounts. The interface is so simple and pages are so small
109             (most under 1k) that it can be used on most limited-functionality browsers
110             such as the text-mode browsers, and the strange micro-browsers found inside
111             video games and mobile phones.
112              
113             The goal is to allow users and be added, removed and fixed from
114             anywhere, even without a computer or "regular" internet connection.
115              
116             =head2 Installing TinyAuth
117              
118             B uses an installation module called L.
119              
120             The process involves firstly installing the TinyAuth distribution to your
121             (Unix, CGI-capable) system via the normal CPAN client, and then running a
122             "CGI Installer" program, which will install a working instance of the
123             application to a specific CGI path.
124              
125             As well ensuring that the CGI setup is correct, this also means that
126             TinyAuth can be installed multiple times on a single host, any each copy
127             can be tweaked or modded as much as you like, without impacting any other
128             users.
129              
130             At the present time, you will need the ability to install modules from CPAN
131             (which generally means root access) but once the application itself is
132             finished, additional improvements are planned to the installer to allow for
133             various alternative installation methods.
134              
135             B
136              
137             Install TinyAuth with your CPAN client
138              
139             adam@svn:~/svn.ali.as$ sudo cpan -i TinyAuth
140              
141             B
142              
143             Run the CGI installation, following the prompts
144              
145             adam@svn:~/svn.ali.as$ cgi_install TinyAuth
146             CGI Directory: [default /home/adam/svn.ali.as] cgi-bin
147             CGI URI: http://svn.ali.as/cgi-bin
148             adam@svn:~/svn.ali.as$
149              
150             The installation is currently extremely crude, so once installed, you
151             currently need to open the tinyauth.conf file created by the installer
152             and edit it by hand (this will be fixed in a forthcoming release).
153              
154             The config file is YAML and should look something like this:
155              
156             adam@svn:~/svn.ali.as$ cat cgi-bin/tinyauth.conf
157             ---
158             email_from: adamk@cpan.org
159             email_driver: SMTP
160             htpasswd: /home/adam/svn.ali.as/cgi-bin/.htpasswd
161            
162             adam@svn:~/svn.ali.as$
163              
164             (For the security concious amoungst you, yes I know that putting the
165             .htpasswd there is a bad idea. No, no real service is actually using
166             that file)
167              
168             The C value is linked to L. Use either
169             "Sendmail" to send via local sendmail, or "SMTP" to send via an SMTP
170             server on localhost.
171              
172             =cut
173              
174 8     8   211 use 5.005;
  8         31  
  8         383  
175 8     8   50 use strict;
  8         17  
  8         1498  
176 8     8   142 use File::Spec ();
  8         3142  
  8         157  
177 8     8   49 use Scalar::Util ();
  8         1236  
  8         1421  
178 8     8   44 use YAML::Tiny ();
  8         14  
  8         258  
179 8     8   1419 use CGI ();
  8         15  
  8         138  
180 8     8   39 use Authen::Htpasswd ();
  8         13  
  8         120  
181 8     8   35 use Email::MIME ();
  8         11  
  8         1306  
182 8     8   39 use Email::MIME::Creator ();
  8         12  
  8         105  
183 8     8   35 use Email::Send ();
  8         12  
  8         163  
184              
185 8     8   37 use vars qw{$VERSION};
  8         12  
  8         453  
186             BEGIN {
187 8     8   37884 $VERSION = '0.98';
188             }
189              
190              
191              
192              
193              
194             #####################################################################
195             # Embedded Functions
196              
197             # Params::Util::_STRING
198             sub _STRING ($) {
199 39 50 33 39   517 (defined $_[0] and ! ref $_[0] and length($_[0])) ? $_[0] : undef;
200             }
201              
202             # Params::Util::_ARRAY
203             sub _ARRAY ($) {
204 45 100 66 45   260 (ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef;
205             }
206              
207             # Params::Util::_INSTANCE
208             sub _INSTANCE ($$) {
209 104 50 33 104   1681 (Scalar::Util::blessed($_[0]) and $_[0]->isa($_[1])) ? $_[0] : undef;
210             }
211              
212              
213              
214              
215              
216              
217             #####################################################################
218             # Constructor and Accessors
219              
220             sub new {
221 26     26 0 294923 my $class = shift;
222 26         328 my $self = bless { @_ }, $class;
223              
224             # Check and set the config
225 26 50       151 unless ( _INSTANCE($self->config, 'YAML::Tiny') ) {
226 0         0 Carp::croak("Did not provide a config param");
227             }
228              
229             # Create the htpasswd shadow
230 26 50       149 unless ( $self->auth ) {
231             # Check for a htpasswd value
232 26 50       125 unless ( $self->htpasswd ) {
233 0         0 Carp::croak("No htpasswd file provided");
234             }
235 26 50       76 unless ( -r $self->htpasswd ) {
236 0         0 Carp::croak("No permission to read htpasswd file");
237             }
238 26 50       83 unless ( -w $self->htpasswd ) {
239 0         0 Carp::croak("No permission to write htpasswd file");
240             }
241 26         85 $self->{auth} = Authen::Htpasswd->new( $self->htpasswd );
242             }
243 26 50       60564 unless ( _INSTANCE($self->auth, 'Authen::Htpasswd') ) {
244 0         0 Carp::croak("Failed to create htpasswd object");
245             }
246              
247             # Create the mailer
248 26 50       173 unless ( $self->email_from ) {
249 0         0 Carp::croak("No email_from address in config file");
250             }
251 26 50       271 unless ( $self->mailer ) {
252 26         139 $self->{mailer} = Email::Send->new( {
253             mailer => $self->email_driver,
254             } );
255             }
256 26 50       77584 unless ( _INSTANCE($self->mailer, 'Email::Send') ) {
257 0         0 Carp::croak("Failed to create mailer");
258             }
259              
260             # Set the header
261 26 50       156 unless ( $self->header ) {
262 26         663 $self->{header} = CGI::header( 'text/html' );
263             }
264              
265             # Set the page title
266 26 50       23058 unless ( $self->title ) {
267 26   33     165 $self->{title} ||= $self->config->[0]->{title};
268 26   33     182 $self->{title} ||= __PACKAGE__ . ' ' . $VERSION;
269             }
270              
271             # Set the homepage
272 26 50       113 unless ( $self->homepage ) {
273 26   33     163 $self->{homepage} ||= $self->config->[0]->{homepage};
274 26   50     147 $self->{homepage} ||= 'http://search.cpan.org/perldoc?TinyAuth';
275             }
276              
277             # Set the CGI object
278 26 50       110 unless ( _INSTANCE($self->cgi, 'CGI') ) {
279 0         0 $self->{cgi} = CGI->new;
280             }
281              
282             # Determine the action
283 26 50       118 unless ( $self->action ) {
284 26   100     82 $self->{action} = $self->cgi->param('a') || '';
285             }
286              
287             # Set the base arguments
288 26   50     1172 $self->{args} ||= {
289             CLASS => ref($self),
290             VERSION => $self->VERSION,
291             SCRIPT_NAME => $ENV{SCRIPT_NAME},
292             HOMEPAGE => $self->homepage,
293             TITLE => $self->title,
294             DOCTYPE => $self->html__doctype,
295             HEAD => $self->html__head,
296             };
297              
298             # Apply security policy
299 26         100 my ($username, $password) = ();
300 26 100 66     90 if ( $self->cgi->param('E') or $self->cgi->param('P') ) {
    100 66        
301 2         38 $username = $self->cgi->param('E');
302 2         29 $password = $self->cgi->param('P');
303 2         38 $self->{user} = $self->authenticate( $username, $password );
304             } elsif ( $self->cgi->cookie('e') and $self->cgi->cookie('p') ) {
305 11         6516 $username = $self->cgi->cookie('e');
306 11         6240 $password = $self->cgi->cookie('p');
307 11         6081 $self->{user} = $self->lookup_user( $username, $password );
308 11 50 33     40 if ( $self->{user} and ! $self->{user}->check_password($password) ) {
309 0         0 $self->{action} = 'o';
310             }
311             } else {
312 13         43852 delete $self->{user};
313             }
314 26 100       192745 if ( ref $self->{user} ) {
315 12 50       122 unless ( $self->is_user_admin($self->{user}) ) {
316 0         0 $self->error('Only administrators are allowed to do that');
317             }
318              
319             # Authenticated ok, set the cookies
320 12         598 $self->{header} = CGI::header(
321             -cookie => [
322             CGI::cookie(
323             -name => 'e',
324             -value => $username,
325             -path => '/',
326             -expires => '+1d',
327             ),
328             CGI::cookie(
329             -name => 'p',
330             -value => $password,
331             -path => '/',
332             -expires => '+1d',
333             ),
334             ],
335             );
336              
337             } else {
338 14         34 delete $self->{user};
339             }
340              
341 26         22691 return $self;
342             }
343              
344             sub config_file {
345 0     0 0 0 $_[0]->{config_file};
346             }
347              
348             sub config {
349 239     239 0 3467 $_[0]->{config};
350             }
351              
352             sub cgi {
353 201     201 0 10931 $_[0]->{cgi};
354             }
355              
356             sub auth {
357 83     83 0 449 $_[0]->{auth};
358             }
359              
360             sub mailer {
361 57     57 0 449 $_[0]->{mailer};
362             }
363              
364             sub user {
365 9     9 0 2777 $_[0]->{user};
366             }
367              
368             sub action {
369 254     254 0 1235 $_[0]->{action};
370             }
371              
372             sub header {
373 26     26 0 121 $_[0]->{header};
374             }
375              
376             sub title {
377 52     52 0 266 $_[0]->{title};
378             }
379              
380             sub homepage {
381 52     52 0 338 $_[0]->{homepage};
382             }
383              
384             sub args {
385 31     31 0 46 return { %{$_[0]->{args}} };
  31         492  
386             }
387              
388             sub htpasswd {
389 104     104 0 230 $_[0]->config->[0]->{htpasswd};
390             }
391              
392             sub email_from {
393 31     31 0 140 $_[0]->config->[0]->{email_from};
394             }
395              
396             sub email_driver {
397 26 50   26 0 81 $_[0]->config->[0]->{email_driver} || 'Sendmail';
398             }
399              
400              
401              
402              
403              
404             #####################################################################
405             # Main Methods
406              
407             sub run {
408 26     26 0 30635 my $self = shift;
409 26 100       112 return 1 if $self->action eq 'error';
410              
411 25 100       81 return $self->action_logout if $self->action eq 'o';
412 24 100       133 return $self->view_forgot if $self->action eq 'f';
413 23 100       115 return $self->action_forgot if $self->action eq 'r';
414 21 100       63 return $self->view_change if $self->action eq 'c';
415 20 100       59 return $self->action_change if $self->action eq 'p';
416 19 100       51 return $self->view_new if $self->action eq 'n';
417 17 100       48 return $self->action_new if $self->action eq 'a';
418 15 100       40 return $self->view_list if $self->action eq 'l';
419 13 100       30 return $self->view_promote if $self->action eq 'm';
420 11 100       31 return $self->action_promote if $self->action eq 'b';
421 8 100       22 return $self->view_delete if $self->action eq 'd';
422 6 100       17 return $self->action_delete if $self->action eq 'e';
423              
424 3         13 return $self->view_index;
425             }
426              
427             # Cloned and simplified from String::MkPasswd
428             sub mkpasswd {
429 2     2 0 26 my @upper = ( 'A' .. 'Z' );
430 2         23 my @lower = ( 'a' .. 'z' );
431 2         8 my @nums = ( 0 .. 9 );
432 2         19 my @spec = (
433             qw| ^ & * ( ) - = _ + [ ] { } \ ; : < > . ? / |,
434             ",", "|", '"', "'",
435             );
436              
437             # Assemble the password characters
438 2         4 my @password = ();
439 2         9 push @password, map { $upper[int rand $#upper] } (0..1);
  4         100  
440 2         7 push @password, map { $spec[ int rand $#spec ] } (0..1);
  4         15  
441 2         6 push @password, map { $nums[ int rand $#nums ] } (0..1);
  4         14  
442 2         7 push @password, map { $lower[int rand $#lower] } (0..4);
  10         28  
443              
444             # Join the characters to get the final password
445 2         14 return join( '', sort { rand(1) <=> rand(1) } @password );
  47         74  
446             }
447             # Inlined from Email::Stuff
448             sub send_email {
449 5     5 0 11 my $self = shift;
450 5         30 my %params = @_;
451              
452             # Create the email
453 5         31 my $email = Email::MIME->create(
454             header => [
455             to => $params{to},
456             from => $self->email_from,
457             subject => $params{subject},
458             ],
459             parts => [
460             Email::MIME->create(
461             attributes => {
462             charset => 'us-ascii',
463             content_type => 'text/plain',
464             format => 'flowed',
465             },
466             body => $params{body},
467             ),
468             ],
469             );
470              
471             # Send the email
472 5         31471 $self->mailer->send( $email );
473              
474 5         1677 return 1;
475             }
476              
477              
478              
479              
480              
481             #####################################################################
482             # Main Methods
483              
484             # The front page
485             sub view_index {
486 4     4 0 7 my $self = shift;
487 4 100       13 $self->print_template(
488             $self->user
489             ? $self->html_index
490             : $self->html_public
491             );
492 4         25 return 1;
493             }
494              
495             # Logout
496             sub action_logout {
497 1     1 0 2 my $self = shift;
498              
499             # Set the user/pass cookies to null
500 1         40 $self->{header} = CGI::header(
501             -cookie => [
502             CGI::cookie(
503             -name => 'e',
504             -value => '0',
505             -path => '/',
506             -expires => '-1y',
507             ),
508             CGI::cookie(
509             -name => 'p',
510             -value => '0',
511             -path => '/',
512             -expires => '-1y',
513             ),
514             ],
515             );
516              
517             # Clear the current user
518 1         1307 delete $self->{user};
519            
520             # Return to the index page
521 1         6 return $self->view_index;
522             }
523              
524             # Show the "I forgot my password" form
525             sub view_forgot {
526 1     1 0 3 my $self = shift;
527 1         9 $self->print_template(
528             $self->html_forgot,
529             );
530 1         7 return 1;
531             }
532              
533             # Re-issue a password
534             sub action_forgot {
535 2     2 0 5 my $self = shift;
536 2         6 my $email = _STRING($self->cgi->param('e'));
537 2 50       9 unless ( $email ) {
538 0         0 return $self->error("You did not enter an email address");
539             }
540              
541             # Does the account exist
542 2         8 my $user = $self->auth->lookup_user($email);
543 2 100       1162 unless ( $user ) {
544 1         12 return $self->error("No account for that email address");
545             }
546              
547             # Create the new password
548 1         16 my $password = $self->mkpasswd;
549 1         5 $user->password($password);
550 1         3264 $self->auth->update_user($user);
551 1         781 $self->{args}->{password} = $password;
552              
553             # Send the password email
554 1         11 $self->send_forgot( $user );
555              
556             # Show the "password email sent" page
557 1         13 $self->view_message("Password email sent");
558             }
559              
560             sub send_forgot {
561 1     1 0 3 my ($self, $user) = @_;
562 1         6 $self->send_email(
563             to => $user->username,
564             subject => '[TinyAuth] Forgot Your Password',
565             body => $self->template(
566             $self->email_forgot,
567             ),
568             );
569             }
570              
571             sub view_list {
572 2     2 0 4 my $self = shift;
573 2 100       10 $self->admins_only or return 1;
574              
575             # Prepare the user list
576 1         8 my @users = $self->all_users;
577 1         2 my $list = '';
578 1         3 foreach my $user ( @users ) {
579 3         341 my $item = $self->cgi->escapeHTML($user->username);
580 3 100       637 if ( $self->is_user_admin($user) ) {
581 1         4 $item = $self->cgi->b($item);
582             }
583 3         889 $list .= $item . $self->cgi->br . "\n";
584             }
585              
586             # Show the page
587 1         37 $self->{args}->{users} = $list;
588 1         10 $self->print_template(
589             $self->html_list,
590             );
591 1         23 return 1;
592             }
593              
594             sub view_promote {
595 2     2 0 5 my $self = shift;
596 2 100       13 $self->admins_only or return 1;
597 1         10 $self->{args}->{users} = $self->user_checkbox_list;
598 1         12 $self->print_template(
599             $self->html_promote,
600             );
601             }
602              
603             sub action_promote {
604 3     3 0 8 my $self = shift;
605 3 100       14 $self->admins_only or return 1;
606              
607             # Which accounts are we promoting
608 2         10 my @accounts = $self->cgi->param('e');
609 2 50       57 unless ( @accounts ) {
610 0         0 return $self->error("You did not select an account");
611             }
612              
613             # Check all the proposed promotions first
614 2         5 my @users = ();
615 2         6 foreach ( @accounts ) {
616 3         9 my $account = _STRING($_);
617 3 50       50 unless ( $account ) {
618 0         0 return $self->error("Missing, invalid, or corrupt email address");
619             }
620              
621             # Does the account exist
622 3         12 my $user = $self->auth->lookup_user($account);
623 3 50       1304 unless ( $user ) {
624 0         0 return $self->error("The account does not exist");
625             }
626              
627             # We can't operate on admins
628 3 50       22 if ( $self->is_user_admin($user) ) {
629 0         0 return $self->error("You cannot control an admin account '$account'");
630             }
631              
632 3         9 push @users, $user;
633             }
634              
635             # Apply the promotions and send mails
636 2         4 foreach my $user ( @users ) {
637 3         11 $user->extra_info('admin');
638              
639             # Send the promotion email
640 3         2769 $self->{args}->{email} = $user->username;
641 3         44 $self->send_promote($user);
642             }
643              
644             # Show the "Promoted ok" page
645 3         20 return $self->view_message(
646             join( "\n", map {
647 2         6 "Promoted account " . $_->username . " to admin"
648             } @users )
649             );
650             }
651              
652             sub send_promote {
653 3     3 0 6 my ($self, $user) = @_;
654 3         12 $self->send_email(
655             to => $user->username,
656             subject => '[TinyAuth] You have been promoted to admin',
657             body => $self->template(
658             $self->email_promote,
659             ),
660             );
661             }
662              
663             sub view_delete {
664 2     2 0 5 my $self = shift;
665 2 100       12 $self->admins_only or return 1;
666 1         11 $self->{args}->{users} = $self->user_checkbox_list;
667 1         10 $self->print_template(
668             $self->html_delete,
669             );
670             }
671              
672             sub action_delete {
673 3     3 0 8 my $self = shift;
674 3 100       15 $self->admins_only or return 1;
675              
676             # Which accounts are we deleting
677 2         12 my @accounts = $self->cgi->param('e');
678 2 50       63 unless ( @accounts ) {
679 0         0 return $self->error("You did not select an account");
680             }
681              
682             # Check all the proposed promotions first
683 2         7 my @users = ();
684 2         44 foreach ( @accounts ) {
685 3         9 my $account = _STRING($_);
686 3 50       10 unless ( $account ) {
687 0         0 return $self->error("Missing, invalid, or corrupt email address");
688             }
689              
690             # Does the account exist
691 3         10 my $user = $self->auth->lookup_user($account);
692 3 50       1431 unless ( $user ) {
693 0         0 return $self->error("The account '$account' does not exist");
694             }
695              
696             # We can't operate on admins
697 3 50       24 if ( $self->is_user_admin($user) ) {
698 0         0 return $self->error("You cannot control admin account '$account'");
699             }
700              
701 3         13 push @users, $user;
702             }
703              
704             # Delete the accounts
705 2         5 foreach my $user ( @users ) {
706 3         846 $self->auth->delete_user($user);
707             }
708              
709             # Show the "Deleted ok" page
710 3         18 return $self->view_message(
711             join( "\n", map {
712 2         1608 "Deleted account " . $_->username
713             } @users )
714             );
715             }
716              
717             sub view_change {
718 1     1 0 4 my $self = shift;
719 1         7 $self->print_template(
720             $self->html_change,
721             );
722 1         8 return 1;
723             }
724              
725             sub action_change {
726 1     1 0 4 my $self = shift;
727 1         4 my $user = $self->authenticate(
728             $self->cgi->param('e'),
729             $self->cgi->param('p'),
730             );
731              
732             # Check the new password
733 1         8 my $new = _STRING($self->cgi->param('n'));
734 1 50       5 unless ( $new ) {
735 0         0 return $self->error("Did not provide a new password");
736             }
737 1         4 my $confirm = _STRING($self->cgi->param('c'));
738 1 50       5 unless ( $confirm ) {
739 0         0 return $self->error("Did not provide a confirmation password");
740             }
741 1 50       4 unless ( $new eq $confirm ) {
742 0         0 return $self->error("New password and confirmation do not match");
743             }
744              
745             # Set the new password
746 1         7 $user->set('password' => $new);
747              
748 1         1059 return $self->view_message("Your password has been changed");
749             }
750              
751             sub view_new {
752 2     2 0 4 my $self = shift;
753 2 100       13 $self->admins_only or return 1;
754 1         10 $self->print_template(
755             $self->html_new,
756             );
757 1         6 return 1;
758             }
759              
760             sub action_new {
761 2     2 0 5 my $self = shift;
762 2 100       11 $self->admins_only or return 1;
763              
764             # Get the new user
765 1         5 my $email = _STRING($self->cgi->param('e'));
766 1 50       5 unless ( $email ) {
767 0         0 return $self->error("You did not enter an email address");
768             }
769              
770             # Does the account exist
771 1 50       4 if ( $self->auth->lookup_user($email) ) {
772 0         0 return $self->error("That account already exists");
773             }
774              
775             # Create the new password
776 1         489 my $password = $self->mkpasswd;
777 1         6 $self->{args}->{email} = $email;
778 1         4 $self->{args}->{password} = $password;
779              
780             # Add the user
781 1         10 my $user = Authen::Htpasswd::User->new($email, $password);
782 1         185 $self->auth->add_user($user);
783              
784             # Send the new user email
785 1         912 $self->send_new($user);
786              
787             # Print the "added" message
788 1         14 return $self->view_message("Added new user $email");
789             }
790              
791             sub send_new {
792 1     1 0 3 my ($self, $user) = @_;
793 1         5 $self->send_email(
794             to => $user->username,
795             subject => '[TinyAuth] Created new account',
796             body => $self->template(
797             $self->email_new,
798             ),
799             );
800             }
801              
802             sub view_message {
803 7     7 0 70 my $self = shift;
804 7         157 $self->{args}->{message} = CGI::escapeHTML(shift);
805 7         1993 $self->{args}->{message} =~ s/\n/
/g;
806 7         61 $self->print_template(
807             $self->html_message,
808             );
809 7         116 return 1;
810             }
811              
812             sub error {
813 9     9 0 17 my $self = shift;
814 9         50 $self->{args}->{error} = shift;
815 9         63 $self->print_template(
816             $self->html_error,
817             );
818 9         25 $self->{action} = 'error';
819 9         41 return 1;
820             }
821              
822              
823              
824              
825              
826             #####################################################################
827             # Support Functions
828              
829             sub print {
830 0     0 0 0 my $self = shift;
831 0 0       0 if ( defined $self->header ) {
832             # Show the page header if this is the first thing
833 0         0 CORE::print( $self->header );
834 0         0 $self->{header} = undef;
835             }
836 0         0 CORE::print( @_ );
837             }
838              
839             sub template {
840 31     31 0 56 my $self = shift;
841 31         57 my $html = shift;
842 31   33     213 my $args = shift || $self->args;
843             # Allow up to 10 levels of recursion
844 31         131 foreach ( 0 .. 10 ) {
845 341         1517 $html =~ s/\[\%\s+(\w+)\s+\%\]/$args->{$1}/g;
846             }
847 31         270 return $html;
848             }
849              
850             sub print_template {
851 26     26 0 63 my $self = shift;
852 26         133 $self->print(
853             $self->template( @_ )
854             );
855 26         337 return 1;
856             }
857              
858             sub is_user_admin {
859 45     45 0 190 my $self = shift;
860 45         64 my $user = shift;
861 45         165 my $info = $user->extra_info;
862 45   66     325 return !! ( _ARRAY($info) and $info->[0] eq 'admin' );
863             }
864              
865             sub all_users {
866 3     3 0 8 my $self = shift;
867 9 50       22 my @list = map { $_->[0] }
  9         36  
868             sort {
869 9         1916 $b->[2] <=> $a->[2] # Admins first
870             or
871             $a->[1] cmp $b->[1] # Then by username
872             }
873 3         17 map { [ $_, $_->username, $self->is_user_admin($_) ] }
874             $self->auth->all_users;
875 3         17 return @list;
876             }
877              
878             sub lookup_user {
879 14     14 0 38 my ($self, $email, $password) = @_;
880              
881             # Check params
882 14 50       90 unless ( defined _STRING($email) ) {
883 0         0 return $self->error("Missing or invalid email address");
884             }
885 14 50       41 unless ( defined _STRING($password) ) {
886 0         0 return $self->error("Missing or invalid password");
887             }
888              
889             # Does the account exist
890 14         51 my $user = $self->auth->lookup_user($email);
891 14 50       8949 unless ( $user ) {
892 0         0 return $self->error("No account for that email address");
893             }
894              
895 14         132 return $user;
896             }
897              
898             sub authenticate {
899 3     3 0 28 my $self = shift;
900 3         18 my $user = $self->lookup_user(@_);
901 3 50       8 return $user unless $user;
902              
903             # Get and check the password
904 3 100       26 unless ( $user->check_password($_[1]) ) {
905 1         3012245 sleep 3;
906 1         25 return $self->error("Incorrect password");
907             }
908              
909 2         41570 return $user;
910             }
911              
912             sub admins_only {
913 16     16 0 31 my $self = shift;
914 16 50       57 my $admin = $_[0] ? shift : $self->{user};
915 16 100 66     92 unless ( $admin and $self->is_user_admin($admin) ) {
916 7         47 $self->error("Only administrators are allowed to do that");
917 7         170 return 0;
918             }
919 9         38 return 1;
920             }
921              
922             sub user_checkbox_list {
923 2     2 0 6 my $self = shift;
924              
925             # Prepare the user list
926 2         5 my $list = '';
927 2         32 foreach my $user ( $self->all_users ) {
928 6         996 my $item = $self->cgi->escapeHTML($user->username);
929 6 100       1858 if ( $self->is_user_admin($user) ) {
930 2         8 $list .= $self->cgi->b(
931             $self->cgi->checkbox(
932             -name => '_',
933             -value => $user->username,
934             -checked => undef,
935             -disabled => undef,
936             -label => $user->username,
937             )
938             );
939             } else {
940 4         14 $list .= $self->cgi->checkbox(
941             -name => 'e',
942             -value => $user->username,
943             -label => $user->username,
944             );
945             }
946 6         11375 $list .= $self->cgi->br . "\n";
947             }
948              
949 2         131 return $list;
950             }
951              
952              
953              
954              
955              
956             #####################################################################
957             # Pages
958              
959              
960              
961              
962              
963 26     26 0 140 sub html__doctype { <<'END_HTML' }
964            
965             END_HTML
966              
967              
968              
969              
970              
971 26     26 0 284 sub html__head { <<'END_HTML' }
972            
973            
974             [% TITLE %]
975            
976             END_HTML
977              
978              
979              
980              
981              
982              
983 2     2 0 10 sub html_public { <<'END_HTML' }
984             [% DOCTYPE %]
985            
986             [% HEAD %]
987            
988            

User

989            

I forgot my password

990            

I want to change my password

991            

Admin

992            
993            

Email

994            

995            

Password

996            

997            

998            
999            
1000            

Powered by TinyAuth

1001            
1002            
1003             END_HTML
1004              
1005              
1006              
1007              
1008              
1009 2     2 0 22 sub html_index { <<'END_HTML' }
1010             [% DOCTYPE %]
1011            
1012             [% HEAD %]
1013            
1014            

User

1015            

I forgot my password

1016            

I want to change my password

1017            

Admin

1018            

Add a new account

1019            

List all accounts

1020            

Delete an account

1021            

Promote an account

1022            

Logout

1023            
1024            

Powered by TinyAuth

1025            
1026            
1027             END_HTML
1028              
1029              
1030              
1031              
1032              
1033 1     1 0 10 sub html_forgot { <<'END_HTML' }
1034             [% DOCTYPE %]
1035            
1036             [% HEAD %]
1037            
1038            

You don't know your password

1039            
1040            
1041            

I can't tell you what your current password is, but I can send you a new one.

1042            

 

1043            

Email Address

1044            

1045            

1046            
1047            
1048            
1049             END_HTML
1050              
1051              
1052              
1053              
1054              
1055 1     1 0 9 sub html_change { <<'END_HTML' }
1056             [% DOCTYPE %]
1057            
1058             [% HEAD %]
1059            
1060            

You want to change your password

1061            

I just need to know a few things to do that

1062            
1063            
1064            
1065            
1066            

What is your email address?

1067            

What is your current password?

1068            

Type in the new password you want  

1069            

Type it again to prevent mistakes

1070            
1071            

1072            

1073            

1074            

1075            
1076            
1077            

Hit the button when you are ready to go

1078            
1079            
1082            
1083            
1084             END_HTML
1085              
1086              
1087              
1088              
1089              
1090 1     1 0 5 sub html_list { <<'END_HTML' }
1091             [% DOCTYPE %]
1092            
1093             [% HEAD %]
1094            
1095            

Account List

1096             [% users %]
1097            
1098            
1099             END_HTML
1100              
1101              
1102              
1103              
1104              
1105 1     1 0 6 sub html_promote { <<'END_HTML' }
1106             [% DOCTYPE %]
1107            
1108             [% HEAD %]
1109            
1110            

Select Account(s) to Promote

1111            
1112            
1113             [% users %]
1114            
1115            
1116            
1117            
1118             END_HTML
1119              
1120              
1121              
1122              
1123              
1124 1     1 0 6 sub html_delete { <<'END_HTML' }
1125             [% DOCTYPE %]
1126            
1127             [% HEAD %]
1128            
1129            

Select Account(s) to Delete

1130            
1131            
1132             [% users %]
1133            
1134            
1135            
1136            
1137             END_HTML
1138              
1139              
1140              
1141              
1142              
1143 1     1 0 4 sub html_new { <<'END_HTML' }
1144             [% DOCTYPE %]
1145            
1146             [% HEAD %]
1147            
1148            

Admin - Add a new user

1149            
1150            
1151            

Email

1152            

1153            

1154            
1155            
1156            
1157             END_HTML
1158              
1159              
1160              
1161              
1162              
1163 7     7 0 39 sub html_message { <<'END_HTML' }
1164             [% DOCTYPE %]
1165            
1166             [% HEAD %]
1167            
1168            

Action Completed

1169            

[% message %]

1170            
1171            
1172             END_HTML
1173              
1174              
1175              
1176              
1177              
1178 9     9 0 63 sub html_error { <<'END_HTML' }
1179             [% DOCTYPE %]
1180            
1181             [% HEAD %]
1182            
1183            

Error

1184            

[% error %]

1185            
1186            
1187             END_HTML
1188              
1189              
1190              
1191              
1192              
1193 1     1 0 16 sub email_forgot { <<'END_TEXT' }
1194             Hi
1195              
1196             You forgot your password, so here is a new one
1197              
1198             Password: [% password %]
1199              
1200             Have a nice day!
1201             END_TEXT
1202              
1203              
1204              
1205              
1206              
1207 1     1 0 16 sub email_new { <<'END_TEXT' }
1208             Hi
1209              
1210             A new account has been created for you
1211              
1212             Email: [% email %]
1213             Password: [% password %]
1214              
1215             Have a nice day!
1216             END_TEXT
1217              
1218              
1219              
1220              
1221              
1222 3     3 0 35 sub email_promote { <<'END_TEXT' }
1223             Hi
1224              
1225             Your account ([% email %]) has been promoted to an administrator.
1226              
1227             You can now login to TinyAuth to get access to additional functions.
1228              
1229             Have a nice day!
1230             END_TEXT
1231              
1232             1;
1233              
1234             =pod
1235              
1236             =head1 SUPPORT
1237              
1238             For all issues, contact the author.
1239              
1240             =head1 AUTHORS
1241              
1242             Adam Kennedy Eadamk@cpan.orgE
1243              
1244             =head1 SEE ALSO
1245              
1246             L, L
1247              
1248             =head1 COPYRIGHT
1249              
1250             Copyright 2007 Adam Kennedy.
1251              
1252             This program is free software; you can redistribute
1253             it and/or modify it under the same terms as Perl itself.
1254              
1255             The full text of the license can be found in the
1256             LICENSE file included with this module.
1257              
1258             =cut