[plack-middleware-auth-complex.git] / lib / Plack / Middleware / Auth / Complex.pm

package Plack::Middleware::Auth::Complex;

use 5.014000;
use strict;
use warnings;

our $VERSION = '0.003001';

use parent qw/Plack::Middleware/;
use re '/s';

use Authen::Passphrase;
use Authen::Passphrase::BlowfishCrypt;
use Data::Entropy qw/entropy_source/;
use Data::Entropy::Source;
use Data::Entropy::RawSource::Local;
use Carp qw/carp croak/;
use DBI;
use Digest::SHA qw/hmac_sha1_base64 sha256/;
use Email::Simple;
use Email::Sender::Simple qw/sendmail/;
use MIME::Base64 qw/decode_base64/;
use Plack::Request;
use Tie::Hash::Expire;

sub make_entropy_source {
	if (-e '/dev/urandom') {
		Data::Entropy::Source->new(
			Data::Entropy::RawSource::Local->new('/dev/urandom'),
			'sysread'
		)
	} else {
		carp "/dev/urandom not found, using insecure random source\n";
		entropy_source
	}
}

sub default_opts {(
	dbi_connect       => ['dbi:Pg:', '', ''],
	select_user       => 'SELECT passphrase, email FROM users WHERE id = ?',
	update_pass       => 'UPDATE users SET passphrase = ? WHERE id = ?',
	insert_user       => 'INSERT INTO users (id, passphrase, email) VALUES (?,?,?)',
	mail_subject      => 'Password reset token',
	realm             => 'restricted area',
	cache_fail        => 0,
	cache_max_age     => 5 * 60,
	token_max_age     => 60 * 60,
	username_regex    => qr/^\w{2,20}$/as,
	invalid_username  => 'Invalid username',
	register_url      => '/action/register',
	passwd_url        => '/action/passwd',
	request_reset_url => '/action/request-reset',
	reset_url         => '/action/reset'
)}

sub new {
	my ($class, $opts) = @_;
	my %self = $class->default_opts;
	%self = (%self, %$opts);
	$self{entropy_source} //= make_entropy_source;
	# If the user did not set [use_scrypt], we set it to 1 if scrypt
	# is available and to 0 otherwise.
	# If the user set [use_scrypt] to 1, we try to load scrypt and
	# croak if we fail to do so.
	unless (exists $self{use_scrypt}) {
		my $success = eval 'use Authen::Passphrase::Scrypt';
		$self{use_scrypt} = !!$success
	}
	if ($self{use_scrypt}) {
		eval 'use Authen::Passphrase::Scrypt; 1' or croak "Failed to load Authen::Passphrase::Scrypt: $@\n";
	}
	my $self = bless \%self, $class;
	$self
}

sub init {
	my ($self) = @_;
	$self->{dbh} = DBI->connect(@{$self->{dbi_connect}})              or croak $DBI::errstr;
	$self->{post_connect_cb}->($self) if $self->{post_connect_cb}; # uncoverable branch false
	$self->{insert_sth} = $self->{dbh}->prepare($self->{insert_user}) or croak $self->{dbh}->errstr;
	$self->{select_sth} = $self->{dbh}->prepare($self->{select_user}) or croak $self->{dbh}->errstr;
	$self->{update_sth} = $self->{dbh}->prepare($self->{update_pass}) or croak $self->{dbh}->errstr;
}

sub create_user {
	my ($self, $parms) = @_;
	my %parms = $parms->flatten;
	$self->{insert_sth}->execute($parms{username}, $self->hash_passphrase($parms{password}), $parms{email}) or croak $self->{insert_sth}->errstr;
}

sub get_user {
	my ($self, $user) = @_;
	$self->{select_sth}->execute($user) or croak $self->{select_sth}->errstr;
	$self->{select_sth}->fetchrow_hashref
}

sub check_passphrase {
	my ($self, $username, $passphrase) = @_;
	unless ($self->{cache}) {
		## no critic (ProhibitTies)
		tie my %cache, 'Tie::Hash::Expire', {expire_seconds => $self->{cache_max_age}};
		$self->{cache} = \%cache;
	}
	my $cachekey = sha256 "$username:$passphrase";
	return $self->{cache}{$cachekey} if exists $self->{cache}{$cachekey}; # uncoverable branch true
	my $user = $self->get_user($username);
	return 0 unless $user;
	my $ret;
	if ($user->{passphrase} =~ /^{SCRYPT}/) {
		croak "$username has a scrypt password but use_scrypt is false\n" unless $self->{use_scrypt};
		$ret = Authen::Passphrase::Scrypt->from_rfc2307($user->{passphrase})
	} else {
		$ret = Authen::Passphrase->from_rfc2307($user->{passphrase});
	}
	$ret = $ret->match($passphrase);
	$self->{cache}{$cachekey} = $ret if $ret || $self->{cache_fail};
	$ret
}

sub hash_passphrase {
	my ($self, $passphrase) = @_;
	if ($self->{use_scrypt}) {
		Authen::Passphrase::Scrypt->new({
			passphrase => $passphrase,
		})->as_rfc2307
	} else {
		Authen::Passphrase::BlowfishCrypt->new(
			cost => 10,
			passphrase => $passphrase,
			salt_random => 1,
		)->as_rfc2307
	}
}

sub set_passphrase {
	my ($self, $username, $passphrase) = @_;
	$self->{update_sth}->execute($self->hash_passphrase($passphrase), $username) or croak $self->{update_sth}->errstr;
}

sub make_reset_hmac {
	my ($self, $username, @data) = @_;
	$self->{hmackey} //= $self->{entropy_source}->get_bits(8 * 512); # uncoverable condition false
	my $user = $self->get_user($username);
	my $message = join ' ', $username, $user->{passphrase}, @data;
	hmac_sha1_base64 $message, $self->{hmackey};
}

sub mail_body {
	my ($self, $username, $token) = @_;
	my $hours = $self->{token_max_age} / 60 / 60;
	$hours .= $hours == 1 ? ' hour' : ' hours'; # uncoverable branch false
	<<"EOF";
Someone has requested a password reset for your account.

To reset your password, please submit the reset password form on the
website using the following information:

Username: $username
Password: <your new password>
Reset token: $token

The token is valid for $hours.
EOF
}

sub send_reset_email {
	my ($self, $username) = @_;
	my $expire = time + $self->{token_max_age};
	my $token = $self->make_reset_hmac($username, $expire) . ":$expire";
	my $user = $self->get_user($username);
	sendmail (Email::Simple->create(
		header => [
			From    => $self->{mail_from},
			To      => $user->{email},
			Subject => $self->{mail_subject},
		],
		body => $self->mail_body($username, $token),
	));
}

##################################################

sub response {
	my ($self, $code, $body) = @_;
	return [
		$code,
		['Content-Type' => 'text/plain',
		 'Content-Length' => length $body],
		[ $body ],
	];
}

sub reply                 { shift->response(200, $_[0]) }
sub bad_request           { shift->response(400, $_[0]) }
sub internal_server_error { shift->response(500, $_[0]) }

sub unauthorized {
	my ($self) = @_;
	my $body = 'Authorization required';
	return [
		401,
		['Content-Type' => 'text/plain',
		 'Content-Length' => length $body,
		 'WWW-Authenticate' => 'Basic realm="' . $self->{realm} . '"' ],
		[ $body ],
	];
}

##################################################

sub call_register {
	my ($self, $req) = @_;
	my %parms;
	for (qw/username password confirm_password email/) {
		$parms{$_} = $req->param($_);
		return $self->bad_request("Missing parameter $_") unless $parms{$_};
	}

	return $self->bad_request($self->{invalid_username}) unless $parms{username} =~ $self->{username_regex};
	return $self->bad_request('Username already in use') if $self->get_user($parms{username});
	return $self->bad_request('The two passwords do not match') unless $parms{password} eq $parms{confirm_password};

	$self->create_user($req->parameters);
	return $self->reply('Registered successfully')
}

sub call_passwd {
	my ($self, $req) = @_;
	return $self->unauthorized unless $req->user;
	my %parms;
	for (qw/password new_password confirm_new_password/) {
		$parms{$_} = $req->param($_);
		return $self->bad_request("Missing parameter $_") unless $parms{$_};
	}

	return $self->bad_request('Incorrect password') unless $self->check_passphrase($req->user, $parms{password});
	return $self->bad_request('The two passwords do not match') unless $parms{new_password} eq $parms{confirm_new_password};
	$self->set_passphrase($req->user, $parms{new_password});
	return $self->reply('Password changed successfully');
}

sub call_request_reset {
	my ($self, $req) = @_;
	return $self->internal_server_error('Password resets are disabled') unless $self->{mail_from};
	my $username = $req->param('username');
	my $user = $self->get_user($username) or return $self->bad_request('No such user');
	eval {
		$self->send_reset_email($username);
		1
	} or return $self->internal_server_error($@);
	$self->reply('Email sent');
}

sub call_reset {
	my ($self, $req) = @_;
	my %parms;
	for (qw/username new_password confirm_new_password token/) {
		$parms{$_} = $req->param($_);
		return $self->bad_request("Missing parameter $_") unless $parms{$_};
	}

	my $user = $self->get_user($parms{username}) or return $self->bad_request('No such user');
	return $self->bad_request('The two passwords do not match') unless $parms{new_password} eq $parms{confirm_new_password};
	my ($token, $exp) = split /:/, $parms{token};
	my $goodtoken = $self->make_reset_hmac($parms{username}, $exp);
	return $self->bad_request('Bad reset token') unless $token eq $goodtoken;
	return $self->bad_request('Reset token has expired') if time >= $exp;
	$self->set_passphrase($parms{username}, $parms{new_password});
	return $self->reply('Password reset successfully');
}

sub call {
	my ($self, $env) = @_;

	unless ($self->{init_done}) {
		$self->init;
		$self->{init_done} = 1;
	}

	my $auth = $env->{HTTP_AUTHORIZATION};
	if ($auth && $auth =~ /^Basic (.*)$/i) {
		my ($user, $pass) = split /:/, decode_base64($1), 2;
		$env->{REMOTE_USER} = $user if $self->check_passphrase($user, $pass);
	}

	my $req = Plack::Request->new($env);

	if ($req->method eq 'POST') {
		return $self->call_register($req)      if $req->path eq $self->{register_url};
		return $self->call_passwd($req)        if $req->path eq $self->{passwd_url};
		return $self->call_request_reset($req) if $req->path eq $self->{request_reset_url};
		return $self->call_reset($req)         if $req->path eq $self->{reset_url};
	}

	$env->{authcomplex} = $self;
	$self->app->($env);
}

1;
__END__

=head1 NAME

Plack::Middleware::Auth::Complex - Feature-rich authentication system

=head1 SYNOPSIS

  use Plack::Builder;

  builder {
    enable 'Auth::Complex', dbi_connect => ['dbi:Pg:dbname=mydb', '', ''], mail_from => 'nobody@example.org';
    sub {
      my ($env) = @_;
      [200, [], ['Hello ' . ($env->{REMOTE_USER} // 'unregistered user')]]
    }
  }

=head1 DESCRIPTION

AuthComplex is an authentication system for Plack applications that
allows user registration, password changing and password reset.

AuthComplex sets REMOTE_USER if the request includes correct basic
authentication and intercepts POST requests to some configurable URLs.
It also sets C<< $env->{authcomplex} >> to itself before passing the
request.

Some options can be controlled by passing a hashref to the
constructor. More customization can be achieved by subclassing this
module.

=head2 Intercepted URLs

Only POST requests are intercepted. Parameters can be either query
parameters or body parameters. Using query parameters is not
recommended. These endpoints return 200 for success, 400 for client
error and 500 for server errors. All parameters are mandatory.

=over

=item B<POST> /action/register?username=user&password=pw&confirm_password=pw&email=user@example.org

This URL creates a new user with the given username, password and
email. The two passwords must match, the user must match
C<username_regex> and the user must not already exist.

=item B<POST> /action/passwd?password=oldpw&new_password=newpw&confirm_new_password=newpw

This URL changes the password of a user. The user must be
authenticated (otherwise the endpoint will return 401).

=item B<POST> /action/request-reset?username=user

This URL requests a password reset token for the given user. The token
will be sent to the user's email address.

A reset token in the default implementation is C<< base64(HMAC-SHA1("$username $passphrase $expiration_unix_time")) . ":$expiration_user_time" >>.

=item B<POST> /action/reset?username=user&new_password=pw&confirm_new_password=pw&token=token

This URL performs a password reset.

=back

=head2 Constructor arguments

=over

=item dbi_connect

Arrayref of arguments to pass to DBI->connect. Defaults to
C<['dbi:Pg', '', '']>.

=item entropy_source

C<Data::Entropy::Source> object to get random numbers from. By default
uses F</dev/urandom> via C<Data::Entropy::RawSource::Local> if
possible, or the default entropy source otherwise. A warning is
printed if the default entropy source is used, to supress it set this
argument to the default entropy source.

=item use_scrypt

Boolean determining whether to use the scrypt algorithm via the
C<Authen::Passphrase::Scrypt> module.

If true, the default implementation of C<hash_passphrase> uses scrypt
and C<check_passphrase> accepts scrypt passphrases (in addition to
passphrases supported by C<Authen::Passphrase>).

If false, the default implementation of C<hash_passphrase> uses bcrypt
and C<check_passphrase> only accepts passphrases supported by
C<Authen::Passphrase>.

The default value is true if C<Authen::Passphrase::Scrypt> is
installed, false otherwise.

=item post_connect_cb

Callback (coderef) that is called just after connecting to the
database. Used by the testsuite to create the users table.

=item select_user

SQL statement that selects a user by username. Defaults to
C<'SELECT id, passphrase, email FROM users WHERE id = ?'>.

=item update_pass

SQL statement that updates a user's password. Defaults to
C<'UPDATE users SET passphrase = ? WHERE id = ?'>.

=item insert_user

SQL statement that inserts a user. Defaults to
C<'INSERT INTO users (id, passphrase, email) VALUES (?,?,?)'>.

=item hmackey

HMAC key used for password reset tokens. If not provided it is
generated randomly, in which case reset tokens do not persist across
application restarts.

=item mail_from

From: header of password reset emails. If not provided, password reset
is disabled.

=item mail_subject

The subject of password reset emails. Defaults to
C<'Password reset token'>.

=item realm

Authentication realm. Defaults to C<'restricted area'>.

=item cache_fail

If true, all authentication results are cached. If false, only
successful logins are cached. Defaults to false.

=item cache_max_age

Authentication cache timeout, in seconds. Authentication results are
cached for this number of seconds to avoid expensive hashing. Defaults
to 5 minutes.

=item token_max_age

Password reset token validity, in seconds. Defaults to 1 hour.

=item username_regex

Regular expression that matches valid usernames. Defaults to
C<qr/^\w{2,20}$/as>.

=item invalid_username

Error message returned when the username does not match
username_regex. Defaults to C<'Invalid username'>

=item register_url

URL for registering. Defaults to C<'/action/register'>.

=item passwd_url

URL for changing your password. Defaults to C<'/action/passwd'>.

=item request_reset_url

URL for requesting a password reset token by email. Defaults to
C<'/action/request-reset'>.

=item reset_url

URL for resetting your password with a reset token. Defaults to
C<'/action/reset'>.

=back

=head2 Methods

=over

=item B<default_opts>

Returns a list of default options for the constructor.

=item B<new>(I<\%opts>)

Creates a new AuthComplex object.

=item B<init>

Called when the first request is received. The default implementation
connects to the database, calls C<post_connect_cb> and prepares the
SQL statements.

=item B<create_user>(I<$parms>)

Inserts a new user into the database. I<$parms> is a
L<Hash::MultiValue> object containing the request parameters.

=item B<get_user>(I<$username>)

Returns a hashref with (at least) the following keys: passphrase (the
RFC2307-formatted passphrase of the user), email (the user's email
address).

=item B<check_passphrase>(I<$username>, I<$passphrase>)

Returns true if the given plaintext passphrase matches the one
obtained from database. Default implementation uses
L<Authen::Passphrase> (and L<Authen::Passphrase::Scrypt> if
C<use_scrypt> is true).

=item B<hash_passphrase>(I<$passphrase>)

Returns a RFC2307-formatted hash of the passphrase.

If C<use_scrypt> is true, default implementation uses
L<Authen::Passphrase::Scrypt> with default parameters.

If C<use_scrypt> is false, default implementation uses
L<Authen::Passphrase::BlowfishCrypt> with a cost of 10 and a random
salt.

=item B<set_passphrase>(I<$username>, I<$passphrase>)

Changes a user's passphrase to the given value.

=item B<make_reset_hmac>(I<$username>, [I<@data>])

Returns the HMAC part of the reset token.

=item B<mail_body>(I<$username>, I<$token>)

Returns the body of the password reset email for the given username
and password reset token.

=item B<send_reset_email>(I<$username>)

Generates a new reset token and sends it to the user via email.

=item B<response>(I<$code>, I<$body>)

Helper method. Returns a PSGI response with the given response code
and string body.

=item B<reply>(I<$message>)

Shorthand for C<response(200, $message)>.

=item B<bad_request>(I<$message>)

Shorthand for C<response(400, $message)>.

=item B<internal_server_error>(I<$message>)

Shorthand for C<response(500, $message)>.

=item B<unauthorized>

Returns a 401 Authorization required response.

=item B<call_register>(I<$req>)

Handles the C</action/register> endpoint. I<$req> is a Plack::Request object.

=item B<call_passwd>(I<$req>)

Handles the C</action/passwd> endpoint. I<$req> is a Plack::Request object.

=item B<call_request_reset>(I<$req>)

Handles the C</action/request-reset> endpoint. I<$req> is a Plack::Request object.

=item B<call_reset>(I<$req>)

Handles the C</action/reset> endpoint. I<$req> is a Plack::Request object.

=back

=head1 AUTHOR

Marius Gavrilescu, E<lt>marius@ieval.roE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2015-2017 by Marius Gavrilescu

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.20.1 or,
at your option, any later version of Perl 5 you may have available.


=cut
Commit	Line	Data
12aa0bc6 MG	1	package Plack::Middleware::Auth::Complex;
	2
	3	use 5.014000;
	4	use strict;
	5	use warnings;
	6
9e0352f7	7	our $VERSION = '0.003001';
12aa0bc6 MG	8
12aa0bc6 MG	9	use parent qw/Plack::Middleware/;
1f7bfc27	10	use re '/s';
12aa0bc6 MG	11
	12	use Authen::Passphrase;
	13	use Authen::Passphrase::BlowfishCrypt;
61456017 MG	14	use Data::Entropy qw/entropy_source/;
	15	use Data::Entropy::Source;
	16	use Data::Entropy::RawSource::Local;
	17	use Carp qw/carp croak/;
12aa0bc6	18	use DBI;
4c1b8033	19	use Digest::SHA qw/hmac_sha1_base64 sha256/;
12aa0bc6 MG	20	use Email::Simple;
	21	use Email::Sender::Simple qw/sendmail/;
	22	use MIME::Base64 qw/decode_base64/;
	23	use Plack::Request;
4c1b8033	24	use Tie::Hash::Expire;
12aa0bc6	25
61456017 MG	26	sub make_entropy_source {
	27	if (-e '/dev/urandom') {
	28	Data::Entropy::Source->new(
	29	Data::Entropy::RawSource::Local->new('/dev/urandom'),
	30	'sysread'
	31	)
	32	} else {
	33	carp "/dev/urandom not found, using insecure random source\n";
	34	entropy_source
	35	}
	36	}
	37
12aa0bc6 MG	38	sub default_opts {(
	39	dbi_connect => ['dbi:Pg:', '', ''],
	40	select_user => 'SELECT passphrase, email FROM users WHERE id = ?',
	41	update_pass => 'UPDATE users SET passphrase = ? WHERE id = ?',
	42	insert_user => 'INSERT INTO users (id, passphrase, email) VALUES (?,?,?)',
	43	mail_subject => 'Password reset token',
	44	realm => 'restricted area',
4c1b8033 MG	45	cache_fail => 0,
4c1b8033 MG	46	cache_max_age => 5 * 60,
fe1dfcf1	47	token_max_age => 60 * 60,
1f7bfc27	48	username_regex => qr/^\w{2,20}$/as,
cd19b1b4	49	invalid_username => 'Invalid username',
388ed281 MG	50	register_url => '/action/register',
	51	passwd_url => '/action/passwd',
	52	request_reset_url => '/action/request-reset',
	53	reset_url => '/action/reset'
12aa0bc6 MG	54	)}
	55
	56	sub new {
	57	my ($class, $opts) = @_;
	58	my %self = $class->default_opts;
	59	%self = (%self, %$opts);
61456017	60	$self{entropy_source} //= make_entropy_source;
58b36d0a MG	61	# If the user did not set [use_scrypt], we set it to 1 if scrypt
	62	# is available and to 0 otherwise.
	63	# If the user set [use_scrypt] to 1, we try to load scrypt and
	64	# croak if we fail to do so.
	65	unless (exists $self{use_scrypt}) {
	66	my $success = eval 'use Authen::Passphrase::Scrypt';
	67	$self{use_scrypt} = !!$success
	68	}
	69	if ($self{use_scrypt}) {
	70	eval 'use Authen::Passphrase::Scrypt; 1' or croak "Failed to load Authen::Passphrase::Scrypt: $@\n";
	71	}
12aa0bc6	72	my $self = bless \%self, $class;
12aa0bc6 MG	73	$self
	74	}
	75
	76	sub init {
	77	my ($self) = @_;
1f7bfc27	78	$self->{dbh} = DBI->connect(@{$self->{dbi_connect}}) or croak $DBI::errstr;
9d9f4067	79	$self->{post_connect_cb}->($self) if $self->{post_connect_cb}; # uncoverable branch false
1f7bfc27 MG	80	$self->{insert_sth} = $self->{dbh}->prepare($self->{insert_user}) or croak $self->{dbh}->errstr;
	81	$self->{select_sth} = $self->{dbh}->prepare($self->{select_user}) or croak $self->{dbh}->errstr;
	82	$self->{update_sth} = $self->{dbh}->prepare($self->{update_pass}) or croak $self->{dbh}->errstr;
12aa0bc6 MG	83	}
12aa0bc6 MG	84
8637972b MG	85	sub create_user {
	86	my ($self, $parms) = @_;
	87	my %parms = $parms->flatten;
6af8d6cc	88	$self->{insert_sth}->execute($parms{username}, $self->hash_passphrase($parms{password}), $parms{email}) or croak $self->{insert_sth}->errstr;
8637972b MG	89	}
8637972b MG	90
12aa0bc6 MG	91	sub get_user {
12aa0bc6 MG	92	my ($self, $user) = @_;
6af8d6cc	93	$self->{select_sth}->execute($user) or croak $self->{select_sth}->errstr;
12aa0bc6 MG	94	$self->{select_sth}->fetchrow_hashref
	95	}
	96
	97	sub check_passphrase {
	98	my ($self, $username, $passphrase) = @_;
4c1b8033	99	unless ($self->{cache}) {
1f7bfc27	100	## no critic (ProhibitTies)
4c1b8033 MG	101	tie my %cache, 'Tie::Hash::Expire', {expire_seconds => $self->{cache_max_age}};
	102	$self->{cache} = \%cache;
	103	}
	104	my $cachekey = sha256 "$username:$passphrase";
9d9f4067	105	return $self->{cache}{$cachekey} if exists $self->{cache}{$cachekey}; # uncoverable branch true
12aa0bc6 MG	106	my $user = $self->get_user($username);
12aa0bc6 MG	107	return 0 unless $user;
58b36d0a MG	108	my $ret;
	109	if ($user->{passphrase} =~ /^{SCRYPT}/) {
	110	croak "$username has a scrypt password but use_scrypt is false\n" unless $self->{use_scrypt};
	111	$ret = Authen::Passphrase::Scrypt->from_rfc2307($user->{passphrase})
	112	} else {
	113	$ret = Authen::Passphrase->from_rfc2307($user->{passphrase});
	114	}
	115	$ret = $ret->match($passphrase);
4c1b8033 MG	116	$self->{cache}{$cachekey} = $ret if $ret \|\| $self->{cache_fail};
4c1b8033 MG	117	$ret
12aa0bc6 MG	118	}
	119
	120	sub hash_passphrase {
	121	my ($self, $passphrase) = @_;
58b36d0a MG	122	if ($self->{use_scrypt}) {
	123	Authen::Passphrase::Scrypt->new({
	124	passphrase => $passphrase,
	125	})->as_rfc2307
	126	} else {
	127	Authen::Passphrase::BlowfishCrypt->new(
	128	cost => 10,
	129	passphrase => $passphrase,
	130	salt_random => 1,
	131	)->as_rfc2307
	132	}
12aa0bc6 MG	133	}
	134
	135	sub set_passphrase {
	136	my ($self, $username, $passphrase) = @_;
6af8d6cc	137	$self->{update_sth}->execute($self->hash_passphrase($passphrase), $username) or croak $self->{update_sth}->errstr;
12aa0bc6 MG	138	}
	139
	140	sub make_reset_hmac {
	141	my ($self, $username, @data) = @_;
61456017	142	$self->{hmackey} //= $self->{entropy_source}->get_bits(8 * 512); # uncoverable condition false
12aa0bc6 MG	143	my $user = $self->get_user($username);
	144	my $message = join ' ', $username, $user->{passphrase}, @data;
	145	hmac_sha1_base64 $message, $self->{hmackey};
	146	}
	147
	148	sub mail_body {
	149	my ($self, $username, $token) = @_;
	150	my $hours = $self->{token_max_age} / 60 / 60;
9d9f4067	151	$hours .= $hours == 1 ? ' hour' : ' hours'; # uncoverable branch false
1f7bfc27	152	<<"EOF";
12aa0bc6 MG	153	Someone has requested a password reset for your account.
	154
	155	To reset your password, please submit the reset password form on the
	156	website using the following information:
	157
	158	Username: $username
	159	Password: <your new password>
	160	Reset token: $token
	161
	162	The token is valid for $hours.
	163	EOF
	164	}
	165
	166	sub send_reset_email {
	167	my ($self, $username) = @_;
	168	my $expire = time + $self->{token_max_age};
	169	my $token = $self->make_reset_hmac($username, $expire) . ":$expire";
	170	my $user = $self->get_user($username);
	171	sendmail (Email::Simple->create(
	172	header => [
	173	From => $self->{mail_from},
	174	To => $user->{email},
876ab8b5	175	Subject => $self->{mail_subject},
12aa0bc6 MG	176	],
	177	body => $self->mail_body($username, $token),
	178	));
	179	}
	180
	181	##################################################
	182
	183	sub response {
	184	my ($self, $code, $body) = @_;
	185	return [
	186	$code,
	187	['Content-Type' => 'text/plain',
	188	'Content-Length' => length $body],
	189	[ $body ],
	190	];
	191	}
	192
	193	sub reply { shift->response(200, $_[0]) }
	194	sub bad_request { shift->response(400, $_[0]) }
	195	sub internal_server_error { shift->response(500, $_[0]) }
	196
	197	sub unauthorized {
	198	my ($self) = @_;
	199	my $body = 'Authorization required';
	200	return [
	201	401,
	202	['Content-Type' => 'text/plain',
	203	'Content-Length' => length $body,
	204	'WWW-Authenticate' => 'Basic realm="' . $self->{realm} . '"' ],
	205	[ $body ],
	206	];
	207	}
	208
	209	##################################################
	210
	211	sub call_register {
	212	my ($self, $req) = @_;
	213	my %parms;
	214	for (qw/username password confirm_password email/) {
	215	$parms{$_} = $req->param($_);
	216	return $self->bad_request("Missing parameter $_") unless $parms{$_};
	217	}
	218
cd19b1b4	219	return $self->bad_request($self->{invalid_username}) unless $parms{username} =~ $self->{username_regex};
12aa0bc6 MG	220	return $self->bad_request('Username already in use') if $self->get_user($parms{username});
12aa0bc6 MG	221	return $self->bad_request('The two passwords do not match') unless $parms{password} eq $parms{confirm_password};
8637972b MG	222
8637972b MG	223	$self->create_user($req->parameters);
12aa0bc6 MG	224	return $self->reply('Registered successfully')
	225	}
	226
	227	sub call_passwd {
	228	my ($self, $req) = @_;
	229	return $self->unauthorized unless $req->user;
	230	my %parms;
	231	for (qw/password new_password confirm_new_password/) {
	232	$parms{$_} = $req->param($_);
	233	return $self->bad_request("Missing parameter $_") unless $parms{$_};
	234	}
	235
	236	return $self->bad_request('Incorrect password') unless $self->check_passphrase($req->user, $parms{password});
	237	return $self->bad_request('The two passwords do not match') unless $parms{new_password} eq $parms{confirm_new_password};
	238	$self->set_passphrase($req->user, $parms{new_password});
	239	return $self->reply('Password changed successfully');
	240	}
	241
	242	sub call_request_reset {
	243	my ($self, $req) = @_;
	244	return $self->internal_server_error('Password resets are disabled') unless $self->{mail_from};
	245	my $username = $req->param('username');
	246	my $user = $self->get_user($username) or return $self->bad_request('No such user');
12aa0bc6 MG	247	eval {
12aa0bc6 MG	248	$self->send_reset_email($username);
1f7bfc27 MG	249	1
	250	} or return $self->internal_server_error($@);
	251	$self->reply('Email sent');
12aa0bc6 MG	252	}
	253
	254	sub call_reset {
	255	my ($self, $req) = @_;
	256	my %parms;
	257	for (qw/username new_password confirm_new_password token/) {
	258	$parms{$_} = $req->param($_);
	259	return $self->bad_request("Missing parameter $_") unless $parms{$_};
	260	}
	261
	262	my $user = $self->get_user($parms{username}) or return $self->bad_request('No such user');
	263	return $self->bad_request('The two passwords do not match') unless $parms{new_password} eq $parms{confirm_new_password};
1f7bfc27	264	my ($token, $exp) = split /:/, $parms{token};
12aa0bc6 MG	265	my $goodtoken = $self->make_reset_hmac($parms{username}, $exp);
	266	return $self->bad_request('Bad reset token') unless $token eq $goodtoken;
	267	return $self->bad_request('Reset token has expired') if time >= $exp;
	268	$self->set_passphrase($parms{username}, $parms{new_password});
	269	return $self->reply('Password reset successfully');
	270	}
	271
	272	sub call {
	273	my ($self, $env) = @_;
d332726d MG	274
	275	unless ($self->{init_done}) {
	276	$self->init;
	277	$self->{init_done} = 1;
	278	}
	279
12aa0bc6 MG	280	my $auth = $env->{HTTP_AUTHORIZATION};
	281	if ($auth && $auth =~ /^Basic (.*)$/i) {
	282	my ($user, $pass) = split /:/, decode_base64($1), 2;
	283	$env->{REMOTE_USER} = $user if $self->check_passphrase($user, $pass);
	284	}
	285
	286	my $req = Plack::Request->new($env);
	287
	288	if ($req->method eq 'POST') {
	289	return $self->call_register($req) if $req->path eq $self->{register_url};
	290	return $self->call_passwd($req) if $req->path eq $self->{passwd_url};
	291	return $self->call_request_reset($req) if $req->path eq $self->{request_reset_url};
	292	return $self->call_reset($req) if $req->path eq $self->{reset_url};
	293	}
	294
	295	$env->{authcomplex} = $self;
	296	$self->app->($env);
	297	}
	298
	299	1;
	300	__END__
	301
	302	=head1 NAME
	303
	304	Plack::Middleware::Auth::Complex - Feature-rich authentication system
	305
	306	=head1 SYNOPSIS
	307
	308	use Plack::Builder;
	309
	310	builder {
	311	enable 'Auth::Complex', dbi_connect => ['dbi:Pg:dbname=mydb', '', ''], mail_from => 'nobody@example.org';
	312	sub {
	313	my ($env) = @_;
	314	[200, [], ['Hello ' . ($env->{REMOTE_USER} // 'unregistered user')]]
	315	}
	316	}
	317
	318	=head1 DESCRIPTION
	319
	320	AuthComplex is an authentication system for Plack applications that
	321	allows user registration, password changing and password reset.
	322
	323	AuthComplex sets REMOTE_USER if the request includes correct basic
	324	authentication and intercepts POST requests to some configurable URLs.
a27e5239	325	It also sets C<< $env->{authcomplex} >> to itself before passing the
12aa0bc6 MG	326	request.
	327
	328	Some options can be controlled by passing a hashref to the
	329	constructor. More customization can be achieved by subclassing this
	330	module.
	331
	332	=head2 Intercepted URLs
	333
	334	Only POST requests are intercepted. Parameters can be either query
	335	parameters or body parameters. Using query parameters is not
	336	recommended. These endpoints return 200 for success, 400 for client
	337	error and 500 for server errors. All parameters are mandatory.
	338
	339	=over
	340
388ed281	341	=item B<POST> /action/register?username=user&password=pw&confirm_password=pw&email=user@example.org
12aa0bc6 MG	342
	343	This URL creates a new user with the given username, password and
	344	email. The two passwords must match, the user must match
	345	C<username_regex> and the user must not already exist.
	346
388ed281	347	=item B<POST> /action/passwd?password=oldpw&new_password=newpw&confirm_new_password=newpw
12aa0bc6 MG	348
	349	This URL changes the password of a user. The user must be
	350	authenticated (otherwise the endpoint will return 401).
	351
388ed281	352	=item B<POST> /action/request-reset?username=user
12aa0bc6 MG	353
	354	This URL requests a password reset token for the given user. The token
	355	will be sent to the user's email address.
	356
	357	A reset token in the default implementation is C<< base64(HMAC-SHA1("$username $passphrase $expiration_unix_time")) . ":$expiration_user_time" >>.
	358
388ed281	359	=item B<POST> /action/reset?username=user&new_password=pw&confirm_new_password=pw&token=token
12aa0bc6 MG	360
	361	This URL performs a password reset.
	362
	363	=back
	364
	365	=head2 Constructor arguments
	366
	367	=over
	368
	369	=item dbi_connect
	370
	371	Arrayref of arguments to pass to DBI->connect. Defaults to
	372	C<['dbi:Pg', '', '']>.
	373
61456017 MG	374	=item entropy_source
	375
	376	C<Data::Entropy::Source> object to get random numbers from. By default
	377	uses F</dev/urandom> via C<Data::Entropy::RawSource::Local> if
	378	possible, or the default entropy source otherwise. A warning is
	379	printed if the default entropy source is used, to supress it set this
	380	argument to the default entropy source.
	381
58b36d0a MG	382	=item use_scrypt
	383
	384	Boolean determining whether to use the scrypt algorithm via the
	385	C<Authen::Passphrase::Scrypt> module.
	386
	387	If true, the default implementation of C<hash_passphrase> uses scrypt
	388	and C<check_passphrase> accepts scrypt passphrases (in addition to
	389	passphrases supported by C<Authen::Passphrase>).
	390
	391	If false, the default implementation of C<hash_passphrase> uses bcrypt
	392	and C<check_passphrase> only accepts passphrases supported by
	393	C<Authen::Passphrase>.
	394
	395	The default value is true if C<Authen::Passphrase::Scrypt> is
	396	installed, false otherwise.
	397
12aa0bc6 MG	398	=item post_connect_cb
	399
	400	Callback (coderef) that is called just after connecting to the
	401	database. Used by the testsuite to create the users table.
	402
	403	=item select_user
	404
	405	SQL statement that selects a user by username. Defaults to
	406	C<'SELECT id, passphrase, email FROM users WHERE id = ?'>.
	407
	408	=item update_pass
	409
	410	SQL statement that updates a user's password. Defaults to
	411	C<'UPDATE users SET passphrase = ? WHERE id = ?'>.
	412
	413	=item insert_user
	414
	415	SQL statement that inserts a user. Defaults to
	416	C<'INSERT INTO users (id, passphrase, email) VALUES (?,?,?)'>.
	417
	418	=item hmackey
	419
	420	HMAC key used for password reset tokens. If not provided it is
	421	generated randomly, in which case reset tokens do not persist across
	422	application restarts.
	423
	424	=item mail_from
	425
	426	From: header of password reset emails. If not provided, password reset
	427	is disabled.
	428
	429	=item mail_subject
	430
	431	The subject of password reset emails. Defaults to
	432	C<'Password reset token'>.
	433
	434	=item realm
	435
	436	Authentication realm. Defaults to C<'restricted area'>.
	437
4c1b8033 MG	438	=item cache_fail
	439
	440	If true, all authentication results are cached. If false, only
	441	successful logins are cached. Defaults to false.
	442
	443	=item cache_max_age
	444
	445	Authentication cache timeout, in seconds. Authentication results are
	446	cached for this number of seconds to avoid expensive hashing. Defaults
	447	to 5 minutes.
	448
12aa0bc6 MG	449	=item token_max_age
12aa0bc6 MG	450
fe1dfcf1	451	Password reset token validity, in seconds. Defaults to 1 hour.
12aa0bc6 MG	452
	453	=item username_regex
	454
	455	Regular expression that matches valid usernames. Defaults to
1f7bfc27	456	C<qr/^\w{2,20}$/as>.
12aa0bc6	457
cd19b1b4 MG	458	=item invalid_username
	459
	460	Error message returned when the username does not match
	461	username_regex. Defaults to C<'Invalid username'>
	462
12aa0bc6 MG	463	=item register_url
12aa0bc6 MG	464
388ed281	465	URL for registering. Defaults to C<'/action/register'>.
12aa0bc6 MG	466
	467	=item passwd_url
	468
388ed281	469	URL for changing your password. Defaults to C<'/action/passwd'>.
12aa0bc6 MG	470
	471	=item request_reset_url
	472
	473	URL for requesting a password reset token by email. Defaults to
388ed281	474	C<'/action/request-reset'>.
12aa0bc6 MG	475
	476	=item reset_url
	477
	478	URL for resetting your password with a reset token. Defaults to
388ed281	479	C<'/action/reset'>.
12aa0bc6 MG	480
	481	=back
	482
	483	=head2 Methods
	484
	485	=over
	486
	487	=item B<default_opts>
	488
	489	Returns a list of default options for the constructor.
	490
	491	=item B<new>(I<\%opts>)
	492
	493	Creates a new AuthComplex object.
	494
	495	=item B<init>
	496
d332726d	497	Called when the first request is received. The default implementation
12aa0bc6 MG	498	connects to the database, calls C<post_connect_cb> and prepares the
	499	SQL statements.
	500
8637972b MG	501	=item B<create_user>(I<$parms>)
	502
	503	Inserts a new user into the database. I<$parms> is a
	504	L<Hash::MultiValue> object containing the request parameters.
	505
12aa0bc6 MG	506	=item B<get_user>(I<$username>)
	507
	508	Returns a hashref with (at least) the following keys: passphrase (the
	509	RFC2307-formatted passphrase of the user), email (the user's email
	510	address).
	511
	512	=item B<check_passphrase>(I<$username>, I<$passphrase>)
	513
	514	Returns true if the given plaintext passphrase matches the one
58b36d0a MG	515	obtained from database. Default implementation uses
	516	L<Authen::Passphrase> (and L<Authen::Passphrase::Scrypt> if
	517	C<use_scrypt> is true).
12aa0bc6 MG	518
	519	=item B<hash_passphrase>(I<$passphrase>)
	520
58b36d0a MG	521	Returns a RFC2307-formatted hash of the passphrase.
	522
	523	If C<use_scrypt> is true, default implementation uses
	524	L<Authen::Passphrase::Scrypt> with default parameters.
	525
	526	If C<use_scrypt> is false, default implementation uses
	527	L<Authen::Passphrase::BlowfishCrypt> with a cost of 10 and a random
	528	salt.
12aa0bc6 MG	529
	530	=item B<set_passphrase>(I<$username>, I<$passphrase>)
	531
	532	Changes a user's passphrase to the given value.
	533
	534	=item B<make_reset_hmac>(I<$username>, [I<@data>])
	535
	536	Returns the HMAC part of the reset token.
	537
	538	=item B<mail_body>(I<$username>, I<$token>)
	539
	540	Returns the body of the password reset email for the given username
	541	and password reset token.
	542
	543	=item B<send_reset_email>(I<$username>)
	544
	545	Generates a new reset token and sends it to the user via email.
	546
	547	=item B<response>(I<$code>, I<$body>)
	548
	549	Helper method. Returns a PSGI response with the given response code
	550	and string body.
	551
	552	=item B<reply>(I<$message>)
	553
	554	Shorthand for C<response(200, $message)>.
	555
	556	=item B<bad_request>(I<$message>)
	557
	558	Shorthand for C<response(400, $message)>.
	559
	560	=item B<internal_server_error>(I<$message>)
	561
	562	Shorthand for C<response(500, $message)>.
	563
	564	=item B<unauthorized>
	565
	566	Returns a 401 Authorization required response.
	567
	568	=item B<call_register>(I<$req>)
	569
f8d502f0	570	Handles the C</action/register> endpoint. I<$req> is a Plack::Request object.
12aa0bc6 MG	571
	572	=item B<call_passwd>(I<$req>)
	573
f8d502f0	574	Handles the C</action/passwd> endpoint. I<$req> is a Plack::Request object.
12aa0bc6 MG	575
	576	=item B<call_request_reset>(I<$req>)
	577
f8d502f0	578	Handles the C</action/request-reset> endpoint. I<$req> is a Plack::Request object.
12aa0bc6 MG	579
	580	=item B<call_reset>(I<$req>)
	581
f8d502f0	582	Handles the C</action/reset> endpoint. I<$req> is a Plack::Request object.
12aa0bc6 MG	583
	584	=back
	585
	586	=head1 AUTHOR
	587
	588	Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
	589
	590	=head1 COPYRIGHT AND LICENSE
	591
cc5b1b68	592	Copyright (C) 2015-2017 by Marius Gavrilescu
12aa0bc6 MG	593
	594	This library is free software; you can redistribute it and/or modify
	595	it under the same terms as Perl itself, either Perl version 5.20.1 or,
	596	at your option, any later version of Perl 5 you may have available.
	597
	598
	599	=cut