lib/Plack/Middleware/Auth/Complex.pm

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